(defgeneric fmt-aui (aui))
(when *has-fixnum-class*
(defmethod fmt-aui ((aui fixnum))
- (prefixed-fixnum-string aui #\A 7)))
+ (if (>= aui 10000000)
+ (prefixed-fixnum-string aui #\A 8)
+ (prefixed-fixnum-string aui #\A 7))))
(defmethod fmt-aui ((aui integer))
- (prefixed-integer-string aui #\A 7))
+ (if (>= aui 10000000)
+ (prefixed-integer-string aui #\A 8)
+ (prefixed-integer-string aui #\A 7)))
(defmethod fmt-aui ((aui string))
(if (eql (aref aui 0) #\A)
(dolist (term (s#term ucon) (nreverse res))
(dolist (str (s#str term))
(push str res)))))
-
+
(defmethod pfstr ((uterm uterm))
"Return the preferred string for a uterm"
((char-equal #\O c)
"Other"))))
-
+
(defun ucon-parents (con &optional sab)
(ucon-ancestors con sab t))
(let* ((parent-rels (filter-urels-by-rel (s#rel ucon) "par"))
(anc nil))
(when sab
- (setq parent-rels (delete-if-not
+ (setq parent-rels (delete-if-not
(lambda (rel) (string-equal sab (sab rel)))
parent-rels)))
(dolist (rel parent-rels (nreverse anc))
(defmethod cxt-ancestors ((con ucon))
(loop for term in (s#term con)
append (cxt-ancestors term)))
-
+
(defmethod cxt-ancestors ((term uterm))
(loop for str in (s#str term)
append (cxt-ancestors str)))
-
+
(defmethod cxt-ancestors ((str ustr))
"Return the ancestory contexts of a ustr"
(let* ((anc (remove-if-not
(sort anc-this-cxn (lambda (a b) (< (rank a) (rank b))))
anc-lists)))))
-
+
#+scl
(dolist (c '(urank udef usat uso ucxt ustr ulo uterm usty urel ucoc uatx ucon uxw uxnw uxns lexterm labr lagr lcmp lmod lnom lprn lprp lspl ltrm ltyp lwd sdef sstr sstre1 sstre2 usrl))
(let ((cl (find-class c)))
" MAX_ROWS=200000000"
"")
(if (eq *umls-sql-type* :mysql)
- " TYPE=MYISAM DEFAULT CHARACTER latin1"
+ " TYPE=MYISAM CHARACTER SET utf8"
""))))
(defun create-custom-table-cmd (tablename sql-cmd)
(translate-files (find-ufile "MRXW_NONENG.RRF")
extension (noneng-lang-index-files)))
+(defun verify-translation-file (output-path input-ufiles)
+ "Returns t if translation file exists and is correct size. Warns and deletes incomplete translation file."
+ (when (probe-file output-path)
+ (let ((translated-lines 0)
+ (input-lines 0)
+ (eof (cons nil nil)))
+ (catch 'done-counting
+ (with-open-file (ts output-path :direction :input
+ #+(and clisp unicode) :external-format
+ #+(and clisp unicode) charset:utf-8)
+ (do ()
+ ((eq (read-line ts nil eof) eof))
+ (incf translated-lines)))
+ (dolist (input-ufile input-ufiles)
+ (with-umls-ufile (line input-ufile)
+ (incf input-lines)
+ (when (> input-lines translated-lines)
+ (throw 'done-counting 'incomplete)))))
+ (cond
+ ((eql input-lines 0)
+ (error "Input lines is 0")
+ nil)
+ ((< input-lines translated-lines)
+ (format t "Translated file ~A incomplete, deleting...~%" output-path)
+ (delete-file output-path)
+ nil)
+ ((eql input-lines translated-lines)
+ (format t "Translated file ~A already exists: skipping...~%" output-path)
+ t)
+ ((> translated-lines input-lines)
+ (error "Shouldn't happen. Translated lines of ~A is ~D, greater than input lines ~D"
+ output-path translated-lines input-lines)
+ (delete-file output-path)
+ nil)))))
+
(defun translate-files (out-ufile extension input-ufiles)
"Translate a umls file into a format suitable for sql copy cmd"
(let ((output-path (ufile-pathname 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
- #+(and clisp unicode) :external-format
- #+(and clisp unicode) charset:utf-8)
- (dolist (input-ufile input-ufiles)
- (with-umls-ufile (line input-ufile)
- (translate-line out-ufile line ostream)
- (princ #\newline ostream)))))))
+ (when (verify-translation-file output-path input-ufiles)
+ (return-from translate-files output-path))
+ (with-open-file (ostream output-path :direction :output
+ #+(and clisp unicode) :external-format
+ #+(and clisp unicode) charset:utf-8)
+ (dolist (input-ufile input-ufiles)
+ (with-umls-ufile (line input-ufile)
+ (translate-line out-ufile line ostream)
+ (princ #\newline ostream))))))
(defun translate-line (file line strm)
"Translate a single line for sql output"
"Custom tables to create")
(defparameter +custom-cols+
- '(("MRCONSO.RRF" "KPFSTR" "TEXT"
- (slot-value (find-ucol "STR" "MRCONSO.RRF") 'max)
- (lambda (x) (pfstr-hash (parse-ui (nth 0 x)))))
+ '(#+nil ("MRCONSO.RRF" "KPFSTR" "TEXT"
+ (slot-value (find-ucol "STR" "MRCONSO.RRF") 'max)
+ (lambda (x) (pfstr-hash (parse-ui (nth 0 x)))))
+ ;; Set to 1 if term is prefered term for english
+ ("MRCONSO.RRF" "KPFENG" "TINYINT" 0
+ (lambda (x) (if (and (string-equal (nth 1 x) "ENG") ; LAT
+ (string-equal (nth 2 x) "P") ; ts
+ (string-equal (nth 4 x) "PF")) ; stt
+ "1"
+ "0")))
("MRCONSO.RRF" "KCUISUI" "BIGINT" 0
(lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 5 x))))))
("MRCONSO.RRF" "KCUILUI" "BIGINT" 0
(lambda (x) (write-to-string (lui-lrl (parse-ui (nth 3 x))))))
("MRCONSO.RRF" "KSUILRL" "SMALLINT" 0
(lambda (x) (write-to-string (sui-lrl (parse-ui (nth 5 x))))))
- ;; Deprecated, last in 2004AA -- skip index
- #+ignore
- ("MRLO.RRF" "KLRL" "SMALLINT" 0
- (lambda (x) (write-to-string
- (if (zerop (length (nth 4 x)))
- (cui-lrl (parse-ui (nth 0 x)))
- (cuisui-lrl (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 4 x))))))))
("MRSTY.RRF" "KLRL" "SMALLINT" 0
(lambda (x) (write-to-string (cui-lrl (parse-ui (nth 0 x))))))
("MRCOC.RRF" "KLRL" "SMALLINT" 0
(lambda (x) (write-to-string (sab-srl (nth 1 x)))))
("MRDEF.RRF" "KSRL" "SMALLINT" 0
(lambda (x) (write-to-string (sab-srl (nth 4 x)))))
- ("MRCXT.RRF" "KSRL" "SMALLINT" 0
- (lambda (x) (write-to-string (sab-srl (nth 2 x)))))
+ #+nil ("MRCXT.RRF" "KSRL" "SMALLINT" 0 (lambda (x) (write-to-string (sab-srl (nth 2 x)))))
("MRXW_ENG.RRF" "KLRL" "SMALLINT" 0
(lambda (x) (write-to-string (cuisui-lrl (make-cuisui
(parse-ui (nth 2 x))
(lambda (x) (write-to-string (cuisui-lrl (make-cuisui
(parse-ui (nth 2 x))
(parse-ui (nth 4 x)))))))
- ("MRREL.RRF" "KPFSTR2" "TEXT" 1024
- (lambda (x) (pfstr-hash (parse-ui (nth 4 x)))))
- ("MRCOC.RRF" "KPFSTR2" "TEXT" 1024
- (lambda (x) (pfstr-hash (parse-ui (nth 2 x)))))
- ("MRCXT.RRF" "KCUISUI" "BIGINT" 0
- (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 1 x))))))
+
+ ;; FIXME: For MRREF and MRCOC, add lookups to KPFSTR2 using new MRCONSO index KPFENG
+
+ #+nil ("MRREL.RRF" "KPFSTR2" "TEXT" 1024 (lambda (x) (pfstr-hash (parse-ui (nth 4 x)))))
+ #+nil ("MRCOC.RRF" "KPFSTR2" "TEXT" 1024 (lambda (x) (pfstr-hash (parse-ui (nth 2 x)))))
+ #+use-mrctx ("MRCXT.RRF" "KCUISUI" "BIGINT" 0 (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 1 x))))))
("MRSAT.RRF" "KCUILUI" "BIGINT" 0
(lambda (x) (write-to-string (make-cuilui (parse-ui (nth 0 x)) (parse-ui (nth 1 x))))))
("MRSAT.RRF" "KCUISUI" "BIGINT" 0
(defparameter +index-cols+
'(("CUI1" "MRCOC") ("CUI" "MRCONSO") ("LUI" "MRCONSO")
- ("SRL" "MRCONSO") ("AUI" "MRCONSO")
- ("SUI" "MRCONSO") ("CUI" "MRCXT") ("CUI" "MRDEF") ("CUI" "MRLO")
+ ("SRL" "MRCONSO") ("AUI" "MRCONSO") ("KPFENG" "MRCONSO")
+ ("SUI" "MRCONSO") ("CUI" "MRDEF")
("CUI1" "MRREL") ("CUI" "MRSAT") ("LUI" "MRSAT") ("SUI" "MRSAT")
("CUI" "MRSTY")
("TUI" "MRSTY") ("CUI" "MRXNS_ENG")
+ ;; ("CUI" "MRCXT") ("KCUISUI" "MRCXT") ("KSRL" "MRCXT")
+ ("AUI" "MRHIER") ("PTR" "MRHIER") ("CUI" "MRHIER") ("CXN" "MRHIER") ("RELA" "MRHIER") ("PAUI" "MRHIER")
+ ("SAB" "MRHIER")
#+ignore ("NSTR" "MRXNS_ENG" 10)
("CUI" "MRXNW_ENG") ("NWD" "MRXNW_ENG") ("WD" "MRXW_ENG")
("KCUISUI" "MRCONSO") ("KCUILUI" "MRCONSO") ("KCUILRL" "MRCONSO")
- ("KLUILRL" "MRCONSO") ("KCUISUI" "MRCXT")
+ ("KLUILRL" "MRCONSO")
("KCUISUI" "MRSAT") ("KCUILUI" "MRSAT")
("KCUISUI" "MRXW_ENG") ("KCUISUI" "MRXNW_ENG")
("KCUISUI" "MRXNS_ENG") ("KCUISUI" "MRXW_NONENG")
- ("KSRL" "MRCXT") ("KSRL" "MRDEF") ("KSRL" "MRRANK")
+ ("KSRL" "MRDEF") ("KSRL" "MRRANK")
("KSRL" "MRREL") ("KSRL" "MRSAT") ("KLRL" "MRCOC")
- #+ignore ("KLRL" "MRLO") ;; deprecated
("KLRL" "MRSTY") ("KLRL" "MRXW_ENG") ("KLRL" "MRXNW_ENG")
("KLRL" "MRXNS_ENG") ("KLRL" "MRXW_NONENG")
;; LEX indices
("SRL" "MRSAB") ("RSAB" "MRSAB") ("VSAB" "MRSAB") ("RCUI" "MRSAB")
("VCUI" "MRSAB") ("LAT" "MRSAB") ("MAPSETCUI" "MRMAP") ("MAPSETCUI" "MRSMAP")
- ("CUI" "MRHIER") ("AUI" "MRHIER") ("PAUI" "MRHIER"))
+ ("CUI" "MRHIER"))
"Columns in files to index")
&key (lrl "KCUILRL") single distinct order like)
(concatenate
'string
- (format nil "select ~A~{~:@(~A~)~^,~} from ~:@(~A~)"
+ (format nil "select ~A~{~:@(~A~)~^,~} from ~:@(~A~)"
(if distinct "distinct " "") fields table)
(if where-name (format nil " where ~:@(~A~)" where-name) "")
(if where-name
"Query the UMLisp database. Return a list of umlisp objects whose name
is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
`(,query-cmd
- (query-string ,table ,fields ,srl ,where-name ,where-value
+ (query-string ,table ,fields ,srl ,where-name ,where-value
:lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like)))
(defmacro umlisp-query-eval (table fields srl where-name where-value
"Query the UMLisp database. Return a list of umlisp objects whose name
is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
`(mutex-sql-query
- (query-string-eval ,table ,fields ,srl ,where-name ,where-value
+ (query-string-eval ,table ,fields ,srl ,where-name ,where-value
:lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like)))
;; only WHERE-VALUE and SRL are evaluated
order like (query-cmd 'mutex-sql-query))
&body body)
(let ((value (gensym))
- (r (gensym)))
+ (r (gensym)))
(if single
`(let* ((,value ,where-value)
(tuple (car (umlisp-query ,table ,fields ,srl ,where-name ,value
(defun find-ucon-all (&key (srl *current-srl*))
"Return list of all ucon's"
(with-sql-connection (db)
- (clsql:map-query
+ (clsql:map-query
'list
#'(lambda (tuple)
(destructuring-bind (cui pfstr cuilrl) tuple
(defun map-ucon-all (fn &key (srl *current-srl*))
"Map a function over all ucon's"
(with-sql-connection (db)
- (clsql:map-query
+ (clsql:map-query
nil
#'(lambda (tuple)
(destructuring-bind (cui pfstr cuilrl) tuple
(make-instance 'udoc :key dockey :value value :type type :expl expl)))
(defun find-udoc-key-value (key value)
- (let ((tuple (car (mutex-sql-query
+ (let ((tuple (car (mutex-sql-query
(format nil "SELECT TYPE,EXPL FROM MRDOC WHERE DOCKEY='~A' AND VALUE='~A'"
key value)))))
(when tuple
(make-instance 'udoc :key key :value value :type (first tuple) :expl (second tuple)))))
-
+
(defun find-udoc-all ()
"Return all abbreviation documentation"
(collect-umlisp-query (mrdoc (dockey value type expl) nil nil nil)
(defun find-ucon-coc-cui2 (cui2 &key (srl *current-srl*))
"List of ucon with co-occurance cui2"
(ensure-cui-integer cui2)
- (mapcar
+ (mapcar
#'(lambda (cui) (find-ucon-cui cui :srl srl))
(remove-duplicates (mapcar #'cui1 (find-ucoc-cui2 cui2 :srl srl)))))
-(defun find-ulo-cui (cui &key (srl *current-srl*))
- "Return a list of ulo for cui"
- (ensure-cui-integer cui)
- (collect-umlisp-query (mrlo (isn fr un sui sna soui) srl cui cui
- :lrl "KLRL")
- (make-instance 'ulo :isn isn :fr (ensure-integer fr) :un un
- :sui (ensure-integer sui) :sna sna :soui soui)))
-
(defun find-uterm-cui (cui &key (srl *current-srl*))
"Return a list of uterm for cui"
(defun find-uterm-lui (lui &key (srl *current-srl*))
"Return a list of uterm for lui"
(ensure-lui-integer lui)
- (collect-umlisp-query (mrconso (cui lat ts kluilrl) srl lui lui
+ (collect-umlisp-query (mrconso (cui lat ts kluilrl) srl lui lui
:lrl kluilrl :distinct t)
(make-instance 'uterm :cui (ensure-integer cui) :lui lui
:lat lat :ts ts :lrl (ensure-integer kluilrl))))
:cuisui (make-cuisui (ensure-integer cui) sui)
:suppress suppress
:lui (ensure-integer lui) :lrl (ensure-integer ksuilrl))))
-
+
(defun find-ustr-sab (sab &key (srl *current-srl*))
"Return the list of ustr for sab"
(collect-umlisp-query (mrconso (kcuisui) srl sab sab :lrl srl)
(let ((cuisui (ensure-integer kcuisui)))
- (apply #'find-ustr-cuisui
+ (apply #'find-ustr-cuisui
(append
(multiple-value-list (decompose-cuisui cuisui))
(list :srl srl))))))
(defun find-ustr-all (&key (srl *current-srl*))
"Return list of all ustr's"
(with-sql-connection (db)
- (clsql:map-query
+ (clsql:map-query
'list
#'(lambda (tuple)
(destructuring-bind (cui lui sui stt ksuilrl suppress pfstr) tuple
"' and lui='0' and sui='0'")))
(when srl
(string-append ls " and KSRL<=" (prefixed-fixnum-string srl nil 3)))
- (loop for tuple in (mutex-sql-query ls) collect
+ (loop for tuple in (mutex-sql-query ls) collect
(destructuring-bind (code atn sab atv) tuple
(make-instance 'usat :code code :atn atn :sab sab :atv atv)))))
(collect-umlisp-query (mrsab (vcui rcui vsab rsab son sf sver vstart vend imeta
rmeta slc scc srl tfr cfr cxty ttyl atnl lat
cenc curver sabin ssn scit) nil nil nil)
- (make-instance 'usab :vcui (ensure-integer vcui)
+ (make-instance 'usab :vcui (ensure-integer vcui)
:rcui (ensure-integer rcui) :vsab vsab :rsab rsab :son son
:sf sf :sver sver :vstart vstart :vend vend :imeta imeta
:rmeta rmeta :slc slc :scc scc :srl (ensure-integer srl)
ttyl atnl lat cenc curver sabin
ssn scit)
nil key-name key :single t)
- (make-instance 'usab :vcui (ensure-integer vcui)
+ (make-instance 'usab :vcui (ensure-integer vcui)
:rcui (ensure-integer rcui) :vsab vsab :rsab rsab :son son
:sf sf :sver sver :vstart vstart :vend vend :imeta imeta
:rmeta rmeta :slc slc :scc scc :srl (ensure-integer srl)
(ensure-tui-integer tui)
(collect-umlisp-query (mrsty (cui) srl tui tui :lrl klrl :order (cui asc))
(find-ucon-cui (ensure-integer cui) :srl srl)))
-
+
(defun find-ucon-word (word &key (srl *current-srl*) (like nil))
"Return list of ucons that match word. Optionally, use SQL's LIKE syntax"
(collect-umlisp-query-eval ('mrxw_eng '(cui) srl 'wd word :like like :distinct t
(let ((uobjs '()))
(dolist (word (delimited-string-to-list str #\space))
(setq uobjs (append uobjs (funcall obj-lookup-fun word :srl srl))))
- (let ((sorted
+ (let ((sorted
(funcall sort-fun str
(delete-duplicates uobjs :test #'= :key key))))
(if (and (plusp (length sorted))
(multiword-match str (pfstr (first sorted))))
(first sorted)
sorted))))
-
+
(defun find-ucon-multiword (str &key (srl *current-srl*)
(only-exact-if-match t))
(find-uobj-multiword str #'find-ucon-word #'sort-score-pfstr-str
(only-exact-if-match t))
(find-uobj-multiword str #'find-ustr-word #'sort-score-ustr-str
#'sui srl only-exact-if-match))
-
+
(defun sort-score-pfstr-str (str uobjs)
"Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"
(sort-score-umlsclass-str uobjs str #'pfstr))
"Sort a list of objects based on scoring to a string"
(let ((scored '()))
(dolist (obj objs)
- (push (list obj (score-multiword-match str (funcall lookup-func obj)))
+ (push (list obj (score-multiword-match str (funcall lookup-func obj)))
scored))
(mapcar #'car (sort scored #'> :key #'cadr))))
(defun find-labr-eui (eui)
(ensure-eui-integer eui)
- (collect-umlisp-query (lrabr (bas abr eui2 bas2) nil eui eui)
+ (collect-umlisp-query (lrabr (bas abr eui2 bas2) nil eui eui)
(make-instance 'labr :eui eui :bas bas :abr abr :bas2 bas2
:eui2 (ensure-integer eui2))))
(defun find-ltrm-eui (eui)
(ensure-eui-integer eui)
- (collect-umlisp-query (lrtrm (bas gen) nil eui eui)
+ (collect-umlisp-query (lrtrm (bas gen) nil eui eui)
(make-instance 'ltrm :eui eui :bas bas :gen gen)))
(defun find-ltyp-eui (eui)
(with-sql-connection (conn)
(ignore-errors (sql-execute "drop table USTATS" conn))
(sql-execute "create table USTATS (NAME varchar(160), COUNT bigint, SRL integer)" conn)
-
+
(dotimes (srl 5)
(insert-ustats-count conn "Concept Count" "MRCONSO" "distinct CUI" "KCUILRL" srl)
(insert-ustats-count conn "Term Count" "MRCONSO" "distinct KCUILUI" "KCUILRL" srl)
(defun find-count-table (conn table srl count-variable srl-control)
(cond
((stringp srl-control)
- (ensure-integer
- (caar (sql-query (format nil "select count(~a) from ~a where ~a <= ~d"
+ (ensure-integer
+ (caar (sql-query (format nil "select count(~a) from ~a where ~a <= ~d"
count-variable table srl-control srl)
conn))))
((null srl-control)
(ensure-integer
- (caar (sql-query (format nil "select count(~a) from ~a"
+ (caar (sql-query (format nil "select count(~a) from ~a"
count-variable table )
conn))))
(t
0)))
(defun insert-ustats (conn name count srl)
- (sql-execute (format nil "insert into USTATS (name,count,srl) values ('~a',~d,~d)"
- name count (if srl srl 3))
+ (sql-execute (format nil "insert into USTATS (name,count,srl) values ('~a',~d,~d)"
+ name count (if srl srl 3))
conn))
(defun find-ustats-all (&key (srl *current-srl*))
(make-instance 'ustats :name name
:hits (ensure-integer count)
:srl (ensure-integer srl)))))
-
+
(defun find-ustats-srl (srl)
(collect-umlisp-query (ustats (name count) nil srl srl :order (name asc))
(make-instance 'ustats :name name :hits (ensure-integer count))))
projects / umlisp.git / commitdiff