;;; UMLS-Parse General
;;; General purpose Lisp Routines for parsing UMLS files
;;;   and inserting into SQL databases
;;;
;;; Copyright (c) 2001 Kevin M. Rosenberg, M.D.
;;; $Id: parse-common.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $

(in-package :umlisp)

(defun umls-pathname (filename &optional (extension ""))
"Return pathname for a umls filename"
  (etypecase filename
    (string
     (merge-pathnames 
      (make-pathname :name (concatenate 'string filename extension)) 
      (case (char filename 0)
	((#\M #\m)
	 *meta-path*)
	((#\L #\l)
	 *lex-path*)
	((#\S #\s)
	 *net-path*)
	(t
	 *umls-path*))))
    (pathname
      filename)))

(defun read-umls-line (strm)
  "Read a line from a UMLS stream, split into fields"
  (let ((line (read-line strm nil 'eof)))
    (if (stringp line) ;; ensure not 'eof
	(let* ((len (length line))
	      (maybe-remove-terminal ;; LRWD doesn't have '|' at end of line
	       (if (char= #\| (char line (1- len)))
		   (subseq line 0 (1- len))
		 line)))
	  (declare (fixnum len))
	  (delimited-string-to-list maybe-remove-terminal #\|))
      line)))


;;; Find field lengths for LEX and NET files

(defun file-field-lengths (files)
  (let ((lengths '()))
    (dolist (file files)
      (setq file (umls-file-fil file))
      (let (max-field count-field num-fields (count-lines 0))
	(with-umls-file (fields file)
 	  (unless num-fields
	    (setq num-fields (length fields))
	    (setq max-field (make-array num-fields :element-type 'fixnum 
					:initial-element 0))
	    (setq count-field (make-array num-fields :element-type 'number
					  :initial-element 0)))
	  (dotimes (i (length fields))
	    (declare (fixnum i))
	    (let ((len (length (nth i fields))))
	      (incf (aref count-field i) len)
	      (when (> len (aref max-field i))
		(setf (aref max-field i) len))))
	  (incf count-lines))
	(dotimes (i num-fields)
	  (setf (aref count-field i) (float (/ (aref count-field i) count-lines))))
	(push (list file max-field count-field) lengths)))
    (nreverse lengths)))

(defun init-field-lengths ()
  "Initial colstruct field lengths for files that don't have a measurement.
Currently, these are the LEX and NET files."
  (let ((measure-files '()))
    (dolist (file *umls-files*)
      (let ((filename (umls-file-fil file)))
	(unless (or (char= #\M (char filename 0))
		    (char= #\m (char filename 0)))
	  (push file measure-files))))
    (let ((length-lists (file-field-lengths measure-files)))
      (dolist (length-list length-lists)
	(let* ((filename (car length-list))
	       (max-field (cadr length-list))
	       (av-field (caddr length-list))
	       (file (find-umls-file filename)))
	  (when file
	    (if (/= (length max-field) (length (umls-file-fields file)))
		(format t "Warning: Number of file fields ~A doesn't match length of fields in file structure ~S" 
		       max-field file)
	      (dotimes (i (max (length max-field) (length (umls-file-fields file))))
		(declare (fixnum i))
		(let* ((field (nth i (umls-file-fields file)))
		       (col (find-umls-col field filename)))
		  (if col
		      (progn
			(setf (umls-col-max col) (aref max-field i))
			(setf (umls-col-av col) (aref av-field i))
			(add-datatype-to-col col (datatype-for-col (umls-col-col col))))
		  (error "can't find column ~A" field)))))))))))
  


;;; UMLS column/file functions

(defun find-col-in-columns (colname filename cols)
"Returns list of umls-col structure for a column name and a filename"
  (dolist (col cols)
    (when (and (string-equal filename (umls-col-fil col))
	       (string-equal colname (umls-col-col col)))
      (return-from find-col-in-columns col)))
  nil)

(defun find-or-make-col-in-columns (colname filename cols)
  (let ((col (find-col-in-columns colname filename cols)))
    (if col
	col
      ;; try to find column name without a terminal digit
      (let* ((last-char (char colname (1- (length colname))))
	     (digit (- (char-code last-char) (char-code #\0))))
	(if (and (>= digit 0) (<= digit 9))
	    (let ((base-colname (subseq colname 0 (1- (length colname)))))
	      (setq col (find-col-in-columns base-colname filename cols))
	      (if col
		  (let ((new-col (make-umls-col
				  :col (copy-seq colname)
				  :des (copy-seq (umls-col-des col))
				  :ref (copy-seq (umls-col-ref col))
				  :min (umls-col-min col)
				  :max (umls-col-max col)
				  :fil (copy-seq (umls-col-fil col))
				  :sqltype (copy-seq (umls-col-sqltype col))
				  :dty (copy-seq (umls-col-dty col))
				  :parsefunc (umls-col-parsefunc col)
				  :quotechar (copy-seq (umls-col-quotechar col))
				  :datatype (umls-col-datatype col)
				  :custom-value-func (umls-col-custom-value-func col))))
		    (push new-col *umls-cols*)
		    new-col)
		(error "Couldn't find a base column for col ~A in file ~A"
		       colname filename)))
	  (let ((new-col (make-umls-col
			  :col (copy-seq colname)
			  :des "Unknown"
			  :ref ""
			  :min nil
			  :max nil
			  :fil filename
			  :sqltype "VARCHAR"
			  :dty nil
			  :parsefunc #'add-sql-quotes
			  :quotechar "'"
			  :datatype nil
			  :custom-value-func nil)))
	    (push new-col *umls-cols*)
	    new-col))))))

(defun find-umls-col (colname filename)
  "Returns list of umls-col structure for a column name and a filename"
  (find-or-make-col-in-columns colname filename *umls-cols*))

(defun find-umls-file (filename)
  "Returns umls-file structure for a filename"  
  (find-if (lambda (f) (string-equal filename (umls-file-fil f))) *umls-files*))

(defun umls-cols-for-umls-file (file)
  "Returns list of umls-cols for a file structure"  
  (let ((filename (umls-file-fil file)))
    (mapcar (lambda (col) (find-umls-col col filename))
	    (umls-file-fields file))))


;; SQL command functions

(defun create-table-cmd (file)
"Return sql command to create a table"
  (let ((col-func 
	 (lambda (c) 
	   (let ((sqltype (umls-col-sqltype c)))
	     (concatenate 'string (umls-col-col c)
		" "
		(if (or (string-equal sqltype "VARCHAR")
			(string-equal sqltype "CHAR"))
		     (format nil "~a (~a)" sqltype (umls-col-max c))
		  sqltype)
		",")))))
    (format nil "CREATE TABLE ~a (~a)" (umls-file-table file)
	    (string-trim-last-character
	     (mapcar-append-string col-func (umls-cols-for-umls-file 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-values-cmd (file values)
"Return sql insert command for a row of values"  
  (let ((insert-func
	 (lambda (col value)
	   (concatenate
	    'string
	    (umls-col-quotechar col)
	    (if (null (umls-col-parsefunc col)) 
		value
	      (format nil "~A" (funcall (umls-col-parsefunc col) value)))
	    (umls-col-quotechar col)
	    ","))))
    (format
     nil "INSERT INTO ~a (~a) VALUES (~a)"
     (umls-file-table file)
     (string-trim-last-character
      (mapcar-append-string (lambda (c) (concatenate 'string c ","))
			    (umls-file-fields file)))
     (string-trim-last-character
      (concatenate 'string
	(mapcar2-append-string insert-func
			       (remove-custom-cols (umls-file-colstructs file)) 
			       values)
	(custom-col-values (custom-colstructs-for-file file) values "," t)))
     )))

(defun custom-col-values (colstructs values delim doquote)
  "Returns string of column values for SQL inserts for custom columns"
  (let ((result ""))
    (dolist (col colstructs)
      (let* ((func (umls-col-custom-value-func col))
	     (custom-value (funcall func values)))
	(string-append result 
		       (if doquote (umls-col-quotechar col))
		       (escape-backslashes custom-value)
		       (if doquote (umls-col-quotechar col))
		       delim)))
    result))

(defun remove-custom-cols (cols)
  "Remove custom cols from a list col umls-cols"
  (remove-if #'umls-col-custom-value-func 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-colstructs-for-file (file)
  (remove-if-not #'umls-col-custom-value-func (umls-file-colstructs file)))

(defun noneng-lang-index-files ()
  (remove-if-not (lambda (f) (and (> (length (umls-file-fil f)) 4)
			      (string-equal (umls-file-fil f) "MRXW." :end1 5) 
			      (not (string-equal (umls-file-fil f) "MRXW.ENG"))
			      (not (string-equal (umls-file-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 ~a)"
    (concatenate 'string tablename "_" colname "_X") tablename colname
    (if (integerp length)
	(format nil "(~d)" length)
      "")))

(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"
  (mapcar
   (lambda (file)
     (ignore-errors 
      (sql-execute (format nil "DROP TABLE ~a" (umls-file-table file)) conn)))
   *umls-files*))

(defun sql-create-tables (conn)
"SQL Databases: create all tables" 
  (mapcar (lambda (file) (sql-execute (create-table-cmd file) conn)) *umls-files*))

(defun sql-create-custom-tables (conn)
"SQL Databases: create all custom tables"
  (mapcar (lambda (ct)
     (sql-execute (create-custom-table-cmd (car ct) (cadr ct)) conn))
   +custom-tables+))
  
(defun sql-insert-values (conn file)
"SQL Databases: inserts all values for a file"  
  (with-umls-file (line (umls-file-fil file))
		  (sql-execute (insert-values-cmd file line) conn)))

(defun sql-insert-all-values (conn)
"SQL Databases: inserts all values for all files"  
  (mapcar (lambda (file) (sql-insert-values conn file)) *umls-files*))

(defun sql-create-indexes (conn &optional (indexes +index-cols+))
"SQL Databases: create all indexes"
(mapcar 
 (lambda (idx) 
   (sql-execute (create-index-cmd (car idx) (cadr idx) (caddr idx)) conn)) 
 indexes))

(defun create-umls-db-by-insert ()
"SQL Databases: initializes entire database via SQL insert commands"
  (init-umls)
  (init-hash-table)
  (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+)))

(defun create-umls-db (&optional (extension ".trans") 
				 (copy-cmd #'mysql-copy-cmd))
  "SQL Databases: initializes entire database via SQL copy commands"
  (init-umls)
  (init-hash-table)
  (translate-all-files extension)
  (with-sql-connection (conn)
    (sql-drop-tables conn)
    (sql-create-tables conn)
    (mapcar 
     #'(lambda (file) (sql-execute (funcall copy-cmd file extension) conn)) 
     *umls-files*)
    (sql-create-indexes conn)
    (sql-create-custom-tables conn)
    (sql-create-indexes conn +custom-index-cols+)))

(defun translate-all-files (&optional (extension ".trans"))
"Copy translated files and return postgresql copy commands to import"
  (make-noneng-index-file extension)
  (mapcar (lambda (f) (translate-file f extension)) *umls-files*))

(defun translate-file (file extension)
  "Translate a umls file into a format suitable for sql copy cmd"
  (let ((path (umls-pathname (umls-file-fil file) extension)))
    (if (probe-file path)
	(progn
	  (format t "File ~A already exists: skipping~%" path)
	  nil)
      (with-open-file (ostream path :direction :output)
	(with-umls-file (line (umls-file-fil file))
	  (princ (umls-translate file line) ostream)
	  (princ #\newline ostream))
	t))))

(defun make-noneng-index-file (extension)
  "Make non-english index file"
  (let* ((outfile (find-umls-file "MRXW.NONENG"))
	 (path (umls-pathname (umls-file-fil outfile) extension)))
	
    (if (probe-file path)
	(progn
	  (format t "File ~A already exists: skipping~%" path)
	  nil)
      (progn
	(with-open-file (ostream path :direction :output)
	  (dolist (inputfile (noneng-lang-index-files))
	    (with-umls-file (line (umls-file-fil inputfile))
	      (princ (umls-translate outfile line) ostream) ;; use outfile for custom cols
	      (princ #\newline ostream))))
	t))))

(defun pg-copy-cmd (file extension)
"Return postgresql copy statement for a file"  
  (format nil "COPY ~a FROM '~a' using delimiters '|' with null as ''"
	  (umls-file-table file) (umls-pathname (umls-file-fil file) extension)))

(defun mysql-copy-cmd (file extension)
"Return mysql copy statement for a file"  
  (format nil "LOAD DATA LOCAL INFILE \"~a\" INTO TABLE ~a FIELDS TERMINATED BY \"|\""
    (umls-pathname (umls-file-fil file) extension) (umls-file-table file)))

(defun umls-translate (file line)
"Translate a single line for sql output"
(string-trim-last-character
 (concatenate 'string
   (mapcar2-append-string 
    (lambda (col value)
      (concatenate
	  'string
	(if (eq (umls-col-datatype col) 'sql-u)
	    (format nil "~d" (parse-ui value ""))
	  (escape-backslashes value))
	"|"))
    (remove-custom-cols (umls-file-colstructs file)) 
    line)
   (custom-col-values (custom-colstructs-for-file file) line "|" nil))))
   

(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 (umls-file-colstructs file))
	(let* ((avwaste (- (umls-col-max col) (umls-col-av col)))
	       (cwaste (* avwaste (umls-file-rws file))))
	  (unless (zerop cwaste)
	    (if (<= avwaste 6)
		(progn
		  (incf totalunavoidable cwaste)
		  (setq unavoidable (append unavoidable (list (list (umls-file-fil file) (umls-col-col col) avwaste cwaste)))))
	      (progn
		  (incf totalavoidable cwaste)
		  (setq avoidable (append avoidable (list (list (umls-file-fil file) (umls-col-col col) avwaste cwaste))))))
	    (incf totalwaste cwaste)))))
    (values totalwaste totalavoidable totalunavoidable avoidable unavoidable)))

(defun display-waste ()
  (unless *umls-files*
    (init-umls))
  (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"
  (unless *umls-files*
    (init-umls))
  (let ((max 0))
    (declare (fixnum max))
    (dolist (col *umls-cols*)
      (when (> (umls-col-max col) max)
	(setq max (umls-col-max col))))
    max))

(defun max-umls-row ()
  "Return length of longest row"
  (if t
      6000  ;;; hack to use on systems without MRCOLS/MRFILES -- ok for UMLS2001
    (progn
      (unless *umls-files*
	(init-umls))
      (let ((rowsizes '()))
	(dolist (file *umls-files*)
	  (let ((row 0)
		(fields (umls-file-colstructs file)))
	    (dolist (field fields)
	      (incf row (1+ (umls-col-max field))))
	    (push row rowsizes)))
	(car (sort rowsizes #'>))))))