parse-common.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          parse-common.lisp
   6 ;;;; Purpose:       Common, stable parsing routines for UMLisp
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id: parse-common.lisp,v 1.2 2002/10/09 23:03:41 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 (defun umls-pathname (filename &optional (extension ""))
  23 "Return pathname for a umls filename"
  24   (etypecase filename
  25     (string
  26      (merge-pathnames
  27       (make-pathname :name (concatenate 'string filename extension))
  28       (case (char filename 0)
  29         ((#\M #\m)
  30          *meta-path*)
  31         ((#\L #\l)
  32          *lex-path*)
  33         ((#\S #\s)
  34          *net-path*)
  35         (t
  36          *umls-path*))))
  37     (pathname
  38       filename)))
  39
  40 (defun read-umls-line (strm)
  41   "Read a line from a UMLS stream, split into fields"
  42   (let ((line (read-line strm nil 'eof)))
  43     (if (stringp line) ;; ensure not 'eof
  44         (let* ((len (length line))
  45               (maybe-remove-terminal ;; LRWD doesn't have '|' at end of line
  46                (if (char= #\| (char line (1- len)))
  47                    (subseq line 0 (1- len))
  48                  line)))
  49           (declare (fixnum len))
  50           (delimited-string-to-list maybe-remove-terminal #\|))
  51       line)))
  52
  53
  54 ;;; Find field lengths for LEX and NET files
  55
  56 (defun file-field-lengths (files)
  57   (let ((lengths '()))
  58     (dolist (file files)
  59       (setq file (umls-file-fil file))
  60       (let (max-field count-field num-fields (count-lines 0))
  61         (with-umls-file (fields file)
  62           (unless num-fields
  63             (setq num-fields (length fields))
  64             (setq max-field (make-array num-fields :element-type 'fixnum
  65                                         :initial-element 0))
  66             (setq count-field (make-array num-fields :element-type 'number
  67                                           :initial-element 0)))
  68           (dotimes (i (length fields))
  69             (declare (fixnum i))
  70             (let ((len (length (nth i fields))))
  71               (incf (aref count-field i) len)
  72               (when (> len (aref max-field i))
  73                 (setf (aref max-field i) len))))
  74           (incf count-lines))
  75         (dotimes (i num-fields)
  76           (setf (aref count-field i) (float (/ (aref count-field i) count-lines))))
  77         (push (list file max-field count-field) lengths)))
  78     (nreverse lengths)))
  79
  80 (defun init-field-lengths ()
  81   "Initial colstruct field lengths for files that don't have a measurement.
  82 Currently, these are the LEX and NET files."
  83   (let ((measure-files '()))
  84     (dolist (file *umls-files*)
  85       (let ((filename (umls-file-fil file)))
  86         (unless (or (char= #\M (char filename 0))
  87                     (char= #\m (char filename 0)))
  88           (push file measure-files))))
  89     (let ((length-lists (file-field-lengths measure-files)))
  90       (dolist (length-list length-lists)
  91         (let* ((filename (car length-list))
  92                (max-field (cadr length-list))
  93                (av-field (caddr length-list))
  94                (file (find-umls-file filename)))
  95           (when file
  96             (if (/= (length max-field) (length (umls-file-fields file)))
  97                 (format t "Warning: Number of file fields ~A doesn't match length of fields in file structure ~S"
  98                        max-field file)
  99               (dotimes (i (max (length max-field) (length (umls-file-fields file))))
 100                 (declare (fixnum i))
 101                 (let* ((field (nth i (umls-file-fields file)))
 102                        (col (find-umls-col field filename)))
 103                   (if col
 104                       (progn
 105                         (setf (umls-col-max col) (aref max-field i))
 106                         (setf (umls-col-av col) (aref av-field i))
 107                         (add-datatype-to-col col (datatype-for-col (umls-col-col col))))
 108                   (error "can't find column ~A" field)))))))))))
 109
 110
 111
 112 ;;; UMLS column/file functions
 113
 114 (defun find-col-in-columns (colname filename cols)
 115 "Returns list of umls-col structure for a column name and a filename"
 116   (dolist (col cols)
 117     (when (and (string-equal filename (umls-col-fil col))
 118                (string-equal colname (umls-col-col col)))
 119       (return-from find-col-in-columns col)))
 120   nil)
 121
 122 (defun find-or-make-col-in-columns (colname filename cols)
 123   (let ((col (find-col-in-columns colname filename cols)))
 124     (if col
 125         col
 126       ;; try to find column name without a terminal digit
 127       (let* ((last-char (char colname (1- (length colname))))
 128              (digit (- (char-code last-char) (char-code #\0))))
 129         (if (and (>= digit 0) (<= digit 9))
 130             (let ((base-colname (subseq colname 0 (1- (length colname)))))
 131               (setq col (find-col-in-columns base-colname filename cols))
 132               (if col
 133                   (let ((new-col (make-umls-col
 134                                   :col (copy-seq colname)
 135                                   :des (copy-seq (umls-col-des col))
 136                                   :ref (copy-seq (umls-col-ref col))
 137                                   :min (umls-col-min col)
 138                                   :max (umls-col-max col)
 139                                   :fil (copy-seq (umls-col-fil col))
 140                                   :sqltype (copy-seq (umls-col-sqltype col))
 141                                   :dty (copy-seq (umls-col-dty col))
 142                                   :parsefunc (umls-col-parsefunc col)
 143                                   :quotechar (copy-seq (umls-col-quotechar col))
 144                                   :datatype (umls-col-datatype col)
 145                                   :custom-value-func (umls-col-custom-value-func col))))
 146                     (push new-col *umls-cols*)
 147                     new-col)
 148                 (error "Couldn't find a base column for col ~A in file ~A"
 149                        colname filename)))
 150           (let ((new-col (make-umls-col
 151                           :col (copy-seq colname)
 152                           :des "Unknown"
 153                           :ref ""
 154                           :min nil
 155                           :max nil
 156                           :fil filename
 157                           :sqltype "VARCHAR"
 158                           :dty nil
 159                           :parsefunc #'add-sql-quotes
 160                           :quotechar "'"
 161                           :datatype nil
 162                           :custom-value-func nil)))
 163             (push new-col *umls-cols*)
 164             new-col))))))
 165
 166 (defun find-umls-col (colname filename)
 167   "Returns list of umls-col structure for a column name and a filename"
 168   (find-or-make-col-in-columns colname filename *umls-cols*))
 169
 170 (defun find-umls-file (filename)
 171   "Returns umls-file structure for a filename"
 172   (find-if (lambda (f) (string-equal filename (umls-file-fil f))) *umls-files*))
 173
 174 (defun umls-cols-for-umls-file (file)
 175   "Returns list of umls-cols for a file structure"
 176   (let ((filename (umls-file-fil file)))
 177     (mapcar (lambda (col) (find-umls-col col filename))
 178             (umls-file-fields file))))
 179
 180
 181 ;; SQL command functions
 182
 183 (defun create-table-cmd (file)
 184 "Return sql command to create a table"
 185   (let ((col-func
 186          (lambda (c)
 187            (let ((sqltype (umls-col-sqltype c)))
 188              (concatenate 'string (umls-col-col c)
 189                 " "
 190                 (if (or (string-equal sqltype "VARCHAR")
 191                         (string-equal sqltype "CHAR"))
 192                      (format nil "~a (~a)" sqltype (umls-col-max c))
 193                   sqltype)
 194                 ",")))))
 195     (format nil "CREATE TABLE ~a (~a)" (umls-file-table file)
 196             (string-trim-last-character
 197              (mapcar-append-string col-func (umls-cols-for-umls-file file))))))
 198
 199 (defun create-custom-table-cmd (tablename sql-cmd)
 200 "Return SQL command to create a custom table"
 201   (format nil "CREATE TABLE ~a AS ~a;" tablename sql-cmd))
 202
 203 (defun insert-values-cmd (file values)
 204 "Return sql insert command for a row of values"
 205   (let ((insert-func
 206          (lambda (col value)
 207            (concatenate
 208             'string
 209             (umls-col-quotechar col)
 210             (if (null (umls-col-parsefunc col))
 211                 value
 212               (format nil "~A" (funcall (umls-col-parsefunc col) value)))
 213             (umls-col-quotechar col)
 214             ","))))
 215     (format
 216      nil "INSERT INTO ~a (~a) VALUES (~a)"
 217      (umls-file-table file)
 218      (string-trim-last-character
 219       (mapcar-append-string (lambda (c) (concatenate 'string c ","))
 220                             (umls-file-fields file)))
 221      (string-trim-last-character
 222       (concatenate 'string
 223         (mapcar2-append-string insert-func
 224                                (remove-custom-cols (umls-file-colstructs file))
 225                                values)
 226         (custom-col-values (custom-colstructs-for-file file) values "," t)))
 227      )))
 228
 229 (defun custom-col-values (colstructs values delim doquote)
 230   "Returns string of column values for SQL inserts for custom columns"
 231   (let ((result ""))
 232     (dolist (col colstructs)
 233       (let* ((func (umls-col-custom-value-func col))
 234              (custom-value (funcall func values)))
 235         (string-append result
 236                        (if doquote (umls-col-quotechar col))
 237                        (escape-backslashes custom-value)
 238                        (if doquote (umls-col-quotechar col))
 239                        delim)))
 240     result))
 241
 242 (defun remove-custom-cols (cols)
 243   "Remove custom cols from a list col umls-cols"
 244   (remove-if #'umls-col-custom-value-func cols))
 245
 246 (defun find-custom-cols-for-filename (filename)
 247   (remove-if-not (lambda (x) (string-equal filename (car x))) +custom-cols+))
 248
 249 (defun find-custom-col (filename col)
 250   (find-if (lambda (x) (and (string-equal filename (car x))
 251                             (string-equal col (cadr x)))) +custom-cols+))
 252
 253
 254 (defun custom-colnames-for-filename (filename)
 255   (mapcar #'cadr (find-custom-cols-for-filename filename)))
 256
 257 (defun custom-colstructs-for-file (file)
 258   (remove-if-not #'umls-col-custom-value-func (umls-file-colstructs file)))
 259
 260 (defun noneng-lang-index-files ()
 261   (remove-if-not (lambda (f) (and (> (length (umls-file-fil f)) 4)
 262                               (string-equal (umls-file-fil f) "MRXW." :end1 5)
 263                               (not (string-equal (umls-file-fil f) "MRXW.ENG"))
 264                               (not (string-equal (umls-file-fil f) "MRXW.NONENG"))))
 265                  *umls-files*))
 266
 267 ;;; SQL Command Functions
 268
 269 (defun create-index-cmd (colname tablename length)
 270 "Return sql create index command"
 271   (format nil "CREATE INDEX ~a ON ~a (~a ~a)"
 272     (concatenate 'string tablename "_" colname "_X") tablename colname
 273     (if (integerp length)
 274         (format nil "(~d)" length)
 275       "")))
 276
 277 (defun create-all-tables-cmdfile ()
 278 "Return sql commands to create all tables. Not need for automated SQL import"
 279   (mapcar (lambda (f) (format nil "~a~%~%" (create-table-cmd f))) *umls-files*))
 280
 281
 282 ;; SQL Execution functions
 283
 284 (defun sql-drop-tables (conn)
 285 "SQL Databases: drop all tables"
 286   (mapcar
 287    (lambda (file)
 288      (ignore-errors
 289       (sql-execute (format nil "DROP TABLE ~a" (umls-file-table file)) conn)))
 290    *umls-files*))
 291
 292 (defun sql-create-tables (conn)
 293 "SQL Databases: create all tables"
 294   (mapcar (lambda (file) (sql-execute (create-table-cmd file) conn)) *umls-files*))
 295
 296 (defun sql-create-custom-tables (conn)
 297 "SQL Databases: create all custom tables"
 298   (mapcar (lambda (ct)
 299      (sql-execute (create-custom-table-cmd (car ct) (cadr ct)) conn))
 300    +custom-tables+))
 301
 302 (defun sql-insert-values (conn file)
 303 "SQL Databases: inserts all values for a file"
 304   (with-umls-file (line (umls-file-fil file))
 305                   (sql-execute (insert-values-cmd file line) conn)))
 306
 307 (defun sql-insert-all-values (conn)
 308 "SQL Databases: inserts all values for all files"
 309   (mapcar (lambda (file) (sql-insert-values conn file)) *umls-files*))
 310
 311 (defun sql-create-indexes (conn &optional (indexes +index-cols+))
 312 "SQL Databases: create all indexes"
 313 (mapcar
 314  (lambda (idx)
 315    (sql-execute (create-index-cmd (car idx) (cadr idx) (caddr idx)) conn))
 316  indexes))
 317
 318 (defun create-umls-db-by-insert ()
 319 "SQL Databases: initializes entire database via SQL insert commands"
 320   (init-umls)
 321   (init-hash-table)
 322   (with-sql-connection (conn)
 323 ;;   (sql-drop-tables conn)
 324 ;;   (sql-create-tables conn)
 325 ;;   (sql-insert-all-values conn)
 326    (sql-create-indexes conn)
 327    (sql-create-custom-tables conn)
 328    (sql-create-indexes conn +custom-index-cols+)))
 329
 330 (defun create-umls-db (&optional (extension ".trans")
 331                                  (copy-cmd #'mysql-copy-cmd))
 332   "SQL Databases: initializes entire database via SQL copy commands"
 333   (init-umls)
 334   (init-hash-table)
 335   (translate-all-files extension)
 336   (with-sql-connection (conn)
 337     (sql-drop-tables conn)
 338     (sql-create-tables conn)
 339     (mapcar
 340      #'(lambda (file) (sql-execute (funcall copy-cmd file extension) conn))
 341      *umls-files*)
 342     (sql-create-indexes conn)
 343     (sql-create-custom-tables conn)
 344     (sql-create-indexes conn +custom-index-cols+)))
 345
 346 (defun translate-all-files (&optional (extension ".trans"))
 347 "Copy translated files and return postgresql copy commands to import"
 348   (make-noneng-index-file extension)
 349   (mapcar (lambda (f) (translate-file f extension)) *umls-files*))
 350
 351 (defun translate-file (file extension)
 352   "Translate a umls file into a format suitable for sql copy cmd"
 353   (let ((path (umls-pathname (umls-file-fil file) extension)))
 354     (if (probe-file path)
 355         (progn
 356           (format t "File ~A already exists: skipping~%" path)
 357           nil)
 358       (with-open-file (ostream path :direction :output)
 359         (with-umls-file (line (umls-file-fil file))
 360           (princ (umls-translate file line) ostream)
 361           (princ #\newline ostream))
 362         t))))
 363
 364 (defun make-noneng-index-file (extension)
 365   "Make non-english index file"
 366   (let* ((outfile (find-umls-file "MRXW.NONENG"))
 367          (path (umls-pathname (umls-file-fil outfile) extension)))
 368
 369     (if (probe-file path)
 370         (progn
 371           (format t "File ~A already exists: skipping~%" path)
 372           nil)
 373       (progn
 374         (with-open-file (ostream path :direction :output)
 375           (dolist (inputfile (noneng-lang-index-files))
 376             (with-umls-file (line (umls-file-fil inputfile))
 377               (princ (umls-translate outfile line) ostream) ;; use outfile for custom cols
 378               (princ #\newline ostream))))
 379         t))))
 380
 381 (defun pg-copy-cmd (file extension)
 382 "Return postgresql copy statement for a file"
 383   (format nil "COPY ~a FROM '~a' using delimiters '|' with null as ''"
 384           (umls-file-table file) (umls-pathname (umls-file-fil file) extension)))
 385
 386 (defun mysql-copy-cmd (file extension)
 387 "Return mysql copy statement for a file"
 388   (format nil "LOAD DATA LOCAL INFILE \"~a\" INTO TABLE ~a FIELDS TERMINATED BY \"|\""
 389     (umls-pathname (umls-file-fil file) extension) (umls-file-table file)))
 390
 391 (defun umls-translate (file line)
 392 "Translate a single line for sql output"
 393 (string-trim-last-character
 394  (concatenate 'string
 395    (mapcar2-append-string
 396     (lambda (col value)
 397       (concatenate
 398           'string
 399         (if (eq (umls-col-datatype col) 'sql-u)
 400             (format nil "~d" (parse-ui value ""))
 401           (escape-backslashes value))
 402         "|"))
 403     (remove-custom-cols (umls-file-colstructs file))
 404     line)
 405    (custom-col-values (custom-colstructs-for-file file) line "|" nil))))
 406
 407
 408 (defun umls-fixed-size-waste ()
 409   "Display storage waste if using all fixed size storage"
 410   (let ((totalwaste 0)
 411         (totalunavoidable 0)
 412         (totalavoidable 0)
 413         (unavoidable '())
 414         (avoidable '()))
 415     (dolist (file *umls-files*)
 416       (dolist (col (umls-file-colstructs file))
 417         (let* ((avwaste (- (umls-col-max col) (umls-col-av col)))
 418                (cwaste (* avwaste (umls-file-rws file))))
 419           (unless (zerop cwaste)
 420             (if (<= avwaste 6)
 421                 (progn
 422                   (incf totalunavoidable cwaste)
 423                   (setq unavoidable (append unavoidable (list (list (umls-file-fil file) (umls-col-col col) avwaste cwaste)))))
 424               (progn
 425                   (incf totalavoidable cwaste)
 426                   (setq avoidable (append avoidable (list (list (umls-file-fil file) (umls-col-col col) avwaste cwaste))))))
 427             (incf totalwaste cwaste)))))
 428     (values totalwaste totalavoidable totalunavoidable avoidable unavoidable)))
 429
 430 (defun display-waste ()
 431   (unless *umls-files*
 432     (init-umls))
 433   (multiple-value-bind (tw ta tu al ul) (umls-fixed-size-waste)
 434     (format t "Total waste: ~d~%" tw)
 435     (format t "Total avoidable: ~d~%" ta)
 436     (format t "Total unavoidable: ~d~%" tu)
 437     (format t "Avoidable:~%")
 438     (dolist (w al)
 439       (format t "  (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w)))
 440     (format t "Unavoidable:~%")
 441     (dolist (w ul)
 442       (format t "  (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w)))
 443   ))
 444
 445 (defun max-umls-field ()
 446   "Return length of longest field"
 447   (unless *umls-files*
 448     (init-umls))
 449   (let ((max 0))
 450     (declare (fixnum max))
 451     (dolist (col *umls-cols*)
 452       (when (> (umls-col-max col) max)
 453         (setq max (umls-col-max col))))
 454     max))
 455
 456 (defun max-umls-row ()
 457   "Return length of longest row"
 458   (if t
 459       6000  ;;; hack to use on systems without MRCOLS/MRFILES -- ok for UMLS2001
 460     (progn
 461       (unless *umls-files*
 462         (init-umls))
 463       (let ((rowsizes '()))
 464         (dolist (file *umls-files*)
 465           (let ((row 0)
 466                 (fields (umls-file-colstructs file)))
 467             (dolist (field fields)
 468               (incf row (1+ (umls-col-max field))))
 469             (push row rowsizes)))
 470         (car (sort rowsizes #'>))))))