1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
|
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: parse-common.lisp
;;;; Purpose: Common, stable parsing routines for UMLisp
;;;; Author: Kevin M. Rosenberg
;;;; Created: Apr 2000
;;;;
;;;; $Id$
;;;;
;;;; This file, part of UMLisp, is
;;;; Copyright (c) 2000-2006 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)
(defun ensure-ucols+ufiles (&optional (alwaysclear nil))
"Initialize all UMLS file and column structures if not already initialized"
(handler-case
(when (or alwaysclear (null *umls-files*))
(setf *umls-cols* nil *umls-files* nil)
(gen-ufiles)
(gen-ucols)
(set-ucols-for-ufiles *umls-files*)
(ensure-field-lengths))
(error (e)
(warn "Error reading ucols+ufiles: ~A." e)
(setf *umls-cols* nil *umls-files* nil)
nil))
t)
(defun add-ucols (ucols)
"Adds a ucol or list of ucols to *umls-cols*. Returns input value."
(setq *umls-cols* (append (mklist ucols) *umls-cols*))
ucols)
(defun add-ufiles (ufiles)
"Adds a ufile or list of ufiles to *umls-filess*. Returns input value."
(setq *umls-files* (append (mklist ufiles) *umls-files*))
ufiles)
(defun ufile-pathname (ufile &optional (extension ""))
"Return pathname for a umls filename with an optional extension"
(assert (typep ufile 'ufile))
(let* ((dirs (append (list (dir ufile))
(awhen (subdir ufile) (list it))))
(name-list (delimited-string-to-list (fil ufile) #\.))
(name (if (second name-list)
(first name-list)
(concatenate 'string (first name-list) (or extension ""))))
(type (when (second name-list)
(concatenate 'string (second name-list) (or extension "")))))
(merge-pathnames
(make-pathname :name name :type type
:directory (cons :relative dirs))
*umls-path*)))
(defun umls-pathname (filename &optional (extension ""))
"Return pathname for a umls filename with an optional extension"
(etypecase filename
(string
(let* ((name-list (delimited-string-to-list filename #\.))
(name (if (second name-list)
(first name-list)
(concatenate 'string (first name-list) (or extension ""))))
(type (when (second name-list)
(concatenate 'string (second name-list) (or extension "")))))
(merge-pathnames
(make-pathname :name name :type type)
(case (schar filename 0)
((#\M #\m)
*meta-path*)
((#\L #\l)
*lex-path*)
((#\S #\s)
*net-path*)
(t
*umls-path*)))))
(pathname
filename)))
;;; Find field lengths for LEX and NET files
(defun ensure-field-lengths ()
"Initial colstruct field lengths for files that don't have a measurement.
Currently, these are the LEX and NET files."
(dolist (length-list (ufiles-field-lengths (ufiles-to-measure)))
(destructuring-bind (filename fields-max fields-av) length-list
(let ((file (find-ufile filename)))
(unless file
(error "Can't find ~A filename in ufiles" filename))
(unless (= (length fields-max) (length (fields file)))
(error
"Number of file fields ~A not equal to field count in ufile ~S"
fields-max file))
(dotimes (i (length (fields file)))
(declare (fixnum i))
(let* ((field (nth i (fields file)))
(col (find-ucol field filename)))
(unless col
(error "can't find column ~A" field))
(setf (cmax col) (aref fields-max i))
(setf (av col) (aref fields-av i))
(ensure-ucol-datatype col (datatype-for-colname (col col)))))))))
(defun ufiles-to-measure ()
"Returns a list of ufiles to measure"
(loop for ufile in *umls-files*
unless (or (char= #\M (schar (fil ufile) 0))
(char= #\m (schar (fil ufile) 0)))
collect ufile))
(defun ufiles-field-lengths (ufiles)
"Returns a list of lists of containing (FILE MAX AV)"
(loop for ufile in ufiles collect (file-field-lengths ufile)))
(defun file-field-lengths (ufile)
"Returns a list of FILENAME MAX AV"
(declare (optimize (speed 3) (safety 0)))
(let (fields-max fields-av num-fields (count-lines 0))
(declare (fixnum count-lines))
(with-umls-ufile (line ufile)
(unless num-fields
(setq num-fields (length line))
(setq fields-max (make-array num-fields :element-type 'fixnum
:initial-element 0))
(setq fields-av (make-array num-fields :element-type '(or integer float)
:initial-element 0)))
(dotimes (i num-fields)
(declare (fixnum i))
(let* ((str (nth i line))
(len (length #-(and clisp unicode) str
#+(and clisp unicode)
(if *octet-sql-storage*
(ext:convert-string-to-bytes str charset:utf-8)
str))))
#-(and clisp unicode) (declare (string str))
(declare (type (integer 0 10000000) len))
(incf (aref fields-av i) len)
(when (> len (aref fields-max i))
(setf (aref fields-max i) len))))
(incf count-lines))
(dotimes (i num-fields)
(setf (aref fields-av i) (float (/ (aref fields-av i) count-lines))))
(list (fil ufile) fields-max fields-av)))
;;; UMLS column/file functions
(defun find-ucol-of-colname (colname filename ucols)
"Returns list of umls-col structure for a column name and a filename"
(dolist (ucol ucols nil)
(when (and (string-equal filename (fil ucol))
(string-equal colname (col ucol)))
(return-from find-ucol-of-colname ucol))))
(defun ensure-col-in-columns (colname filename ucols)
(aif (find-ucol-of-colname colname filename ucols)
it
(add-ucols (make-ucol-for-column colname filename ucols))))
(defun make-ucol-for-column (colname filename ucols)
;; try to find column name without a terminal digit
(let* ((len (length colname))
(last-digit? (digit-char-p (schar colname (1- len))))
(base-colname (if last-digit?
(subseq colname 0 (1- len))
colname))
(ucol (when last-digit?
(find-ucol-of-colname base-colname filename ucols))))
(when (and last-digit? (null ucol))
(error "Couldn't find a base column for col ~A in file ~A"
colname filename))
(copy-or-new-ucol colname filename ucol)))
(defun copy-or-new-ucol (colname filename ucol)
(if ucol
(make-instance
'ucol
:col (copy-seq colname) :des (copy-seq (des ucol)) :ref (copy-seq (ref ucol))
:min (cmin ucol) :max (cmax ucol) :fil (copy-seq (fil ucol))
:sqltype (copy-seq (sqltype ucol)) :dty (copy-seq (dty ucol))
:parse-fun (parse-fun ucol) :quote-str (copy-seq (quote-str ucol))
:datatype (datatype ucol) :custom-value-fun (custom-value-fun ucol))
(make-empty-ucol colname filename)))
(defun ensure-compiled-fun (fun)
"Ensure that a function is compiled"
(etypecase fun
(null
nil)
(function
(if (compiled-function-p fun)
fun
(compile nil fun)))
(list
(compile nil fun))))
(defun make-ucol (col des ref min av max fil dty
&key (sqltype "VARCHAR") (parse-fun #'add-sql-quotes)
(quote-str "'") (custom-value-fun))
(let ((ucol (make-instance
'ucol
:col col :des des :ref ref :min min :av av
:max (if (eql max 0) 1 max) ;; ensure at least one char wide
:fil fil
:dty dty
:sqltype sqltype
:quote-str quote-str
:parse-fun (ensure-compiled-fun parse-fun)
:custom-value-fun (ensure-compiled-fun custom-value-fun))))
(ensure-ucol-datatype ucol (datatype-for-colname col))
ucol))
(defun make-empty-ucol (colname filename)
;;(format "call in make-empty-ucol: ~A/~A" colname filename)
(make-ucol (copy-seq colname) "Unknown" "" nil nil nil filename nil))
(defun find-ucol (colname filename)
"Returns list of umls-col structure for a column name and a filename"
(ensure-col-in-columns colname filename *umls-cols*))
(defun find-ufile (filename)
"Returns umls-file structure for a filename"
(find-if #'(lambda (f) (string= filename (fil f))) *umls-files*))
(defun position-field-file (filename fieldname)
"Returns the position of a field in a file"
(let ((ufile (find-ufile filename)))
(unless ufile
(warn "Unable to find ufile for filename ~A." filename)
(return-from position-field-file nil))
(let ((pos (position fieldname (fields ufile) :test #'string=)))
(unless pos
(warn "Unable to find field ~A in ufile ~S." fieldname ufile)
(return-from position-field-file nil))
pos)))
(defun find-ucols-for-ufile (ufile)
"Returns list of umls-cols for a file structure"
(loop for colname in (fields ufile)
collect (find-ucol colname
(if (subdir ufile)
(concatenate 'string (subdir ufile) "/" (fil ufile))
(fil ufile)))))
(defun umls-field-string-to-list (fmt)
"Converts a comma delimited list of fields into a list of field names. Will
append a unique number (starting at 2) onto a column name that is repeated in the list"
(let ((col-counts (make-hash-table :test 'equal)))
(loop for colname in (delimited-string-to-list (escape-column-name fmt) #\,)
collect
(multiple-value-bind (value found) (gethash colname col-counts)
(cond
(found
(incf (gethash colname col-counts))
(concatenate 'string colname (write-to-string (1+ value))))
(t
(setf (gethash colname col-counts) 1)
colname))))))
(defun decompose-fil (fil)
(if fil
(let ((pos (position #\/ fil)))
(if pos
(values (subseq fil (1+ pos)) (subseq fil 0 pos))
(values fil nil)))
(values nil nil)))
(defun filename-to-tablename (file)
(let ((pos (search ".RRF" file)))
(when pos
(setf file (subseq file 0 pos))))
(substitute #\_ #\. file))
(defun make-ufile (dir fil des cls rws bts fields)
(multiple-value-bind (file subdir) (decompose-fil fil)
(let ((ufile (make-instance 'ufile :dir dir :fil file :subdir subdir
:des des :cls cls
:rws rws :bts bts :fields fields
:table (filename-to-tablename file))))
ufile)))
(defun set-ucols-for-ufiles (ufiles)
(dolist (ufile ufiles)
(setf (ucols ufile) (find-ucols-for-ufile ufile))))
(defun datatype-for-colname (colname)
"Return datatype for column name"
(second (find colname +col-datatypes+ :key #'car :test #'string-equal)))
(defun canonicalize-column-type (type)
(cond
((string-equal type "TINYINT")
(case *umls-sql-type*
(:mysql "TINYINT")
((:postgresql :postgresql-socket) "INT1")
(:oracle "NUMBER(3,0)")
(t "INTEGER")))
((string-equal type "SMALLINT")
(case *umls-sql-type*
(:mysql "SMALLINT")
((:postgresql :postgresql-socket) "INT2")
(:oracle "NUMBER(5,0)")
(t "INTEGER")))
((string-equal type "INTEGER")
(case *umls-sql-type*
(:mysql "INTEGER")
((:postgresql :postgresql-socket) "INT4")
(:oracle "NUMBER(9,0)")
(t "INTEGER")))
((string-equal type "BIGINT")
(case *umls-sql-type*
(:mysql "BIGINT")
((:postgresql :postgresql-socket) "INT8")
(:oracle "NUMBER(38,0)")
(t "INTEGER")))
((string-equal type "TEXT")
(case *umls-sql-type*
(:mysql "TEXT")
((:postgresql :postgresql-socket) "TEXT")
(:oracle "VARCHAR2(3000)")
(t "VARCHAR(3000)")))
((string-equal type "VARCHAR")
(case *umls-sql-type*
(:mysql "VARCHAR")
((:postgresql :postgresql-socket) "VARCHAR")
(:oracle "VARCHAR2")
(t "VARCHAR")))
((string-equal type "NUMERIC")
(case *umls-sql-type*
(:mysql "NUMERIC")
((:postgresql :postgresql-socket) "NUMERIC")
(:oracle "NUMBER")
(t "NUMERIC")))
(t
type)))
(defun ensure-ucol-datatype (col datatype)
"Add data type information to column"
(setf (datatype col) datatype)
(case datatype
(sql-u (setf (sqltype col) (canonicalize-column-type "INTEGER")
(parse-fun col) #'parse-ui
(quote-str col) ""))
(sql-s (setf (sqltype col) (canonicalize-column-type "SMALLINT")
(parse-fun col) #'parse-integer
(quote-str col) ""))
(sql-l (setf (sqltype col) (canonicalize-column-type "BIGINT")
(parse-fun col) #'parse-integer
(quote-str col) ""))
(sql-i (setf (sqltype col) (canonicalize-column-type "INTEGER")
(parse-fun col) #'parse-integer
(quote-str col) ""))
(sql-t (setf (sqltype col) (canonicalize-column-type "TINYINT")
(parse-fun col) #'parse-integer
(quote-str col) ""))
(sql-f (setf (sqltype col) (canonicalize-column-type "NUMERIC")
(parse-fun col) #'read-from-string
(quote-str col) ""))
(t ; Default column type, optimized text storage
(setf (parse-fun col) #'add-sql-quotes
(quote-str col) "'")
(when (and (cmax col) (av col))
(if (> (cmax col) 255)
(setf (sqltype col) (canonicalize-column-type "TEXT"))
(setf (sqltype col) (canonicalize-column-type "VARCHAR")))))))
(defun escape-column-name (name)
(substitute #\_ #\/ name))
|
