From 12131484e6e61019e61a281e26d49aaf7dd83690 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sat, 9 Dec 2006 21:44:58 +0000 Subject: [PATCH] r11333: add uconso object; query MRXW filtering by SAB --- classes.lisp | 45 ++++++++++++++++++++++++++- package.lisp | 6 ++-- sql-classes.lisp | 79 ++++++++++++++++++++++++++++++++++++++++++------ 3 files changed, 118 insertions(+), 12 deletions(-) diff --git a/classes.lisp b/classes.lisp index 94c489b..efa685f 100644 --- a/classes.lisp +++ b/classes.lisp @@ -37,7 +37,7 @@ ((rank :value-type fixnum :initarg :rank :reader rank) (sab :value-type string :initarg :sab :reader sab) (tty :value-type string :initarg :tty :reader tty) - (suppres :value-type string :initarg :suppres :reader suppres)) + (suppress :value-type string :initarg :suppress :reader suppress)) (:metaclass hyperobject-class) (:user-name "Rank") (:default-print-slots rank sab tty suppres)) @@ -265,6 +265,49 @@ (:user-name "Concept") (:default-print-slots cui lrl pfstr)) + +(defclass uconso (umlsclass) + ((cui :value-type fixnum :initarg :cui :reader cui :print-formatter fmt-cui + :hyperlink find-ucon-cui) + (lat :value-type string :initarg :lat :reader lat) + (ts :value-type string :initarg :ts :reader ts) + (lui :value-type fixnum :initarg :lui :reader lui :print-formatter fmt-lui) + (stt :value-type string :initarg :stt :reader stt) + (sui :value-type fixnum :initarg :sui :reader sui :print-formatter fmt-sui) + (ispref :value-type string :initarg :ispref :reader ispref) + (aui :value-type fixnum :initarg :aui :reader aui :print-formatter fmt-aui) + (saui :value-type string :initarg :saui :reader saui) + (scui :value-type string :initarg :scui :reader scui) + (sdui :value-type string :initarg :sdui :reader sdui) + (sab :value-type string :initarg :sab :reader sab) + (tty :value-type string :initarg :tty :reader tty) + (code :value-type string :initarg :code :reader code) + (str :value-type string :initarg :str :reader str) + (srl :value-type fixnum :initarg :srl :reader srl) + (suppress :value-type string :initarg :suppress :reader suppress) + (cvf :value-type string :initarg :cvf :reader cvf) + (kpfeng :value-type string :initarg :kpfeng :reader kpfeng) + (kcuisui :value-type bigint :initarg :kcuisui :reader kcuisui) + (kcuilui :value-type bigint :initarg :kcuilui :reader kcuilui) + (kcuilrl :value-type fixnum :initarg :kcuilrl :reader kcuilrl) + (kluilrl :value-type fixnum :initarg :kluilrl :reader kluilrl) + (ksuilrl :value-type fixnum :initarg :ksuilrl :reader ksuilrl) + (s#def :reader s#def :subobject (find-udef-cui cui)) + (s#so :reader s#so :subobject (find-uso-cui cui)) + (s#hier :reader s#hier :subobject (find-uhier-cui cui)) + (s#map :reader s#map :subobject (find-umap-cui cui)) + (s#smap :reader s#smap :subobject (find-usmap-cui cui)) + (s#sty :reader s#sty :subobject (find-usty-cui cui)) + (s#lo :reader s#lo :subobject (find-ulo-cui cui)) + (s#term :reader s#term :subobject (find-uterm-cui cui)) + (s#sat :reader s#sat :subobject (find-usat-ui cui)) + (s#rel :reader s#rel :subobject (find-urel-cui cui)) + (s#coc :reader s#coc :subobject (find-ucoc-cui cui))) + (:documentation "CONSO is a new concept from the RRF files. This object is a rather raw row from the MRCONSO table.") + (:metaclass hyperobject-class) + (:user-name "Concept") + (:default-print-slots cui lrl str sab)) + (defclass umap (umlsclass) ((mapsetcui :value-type fixnum :initarg :mapsetcui :reader mapsetcui) (mapsetsab :value-type string :initarg :mapsetsab :reader mapsetsab) diff --git a/package.lisp b/package.lisp index 1d39df0..6e21f7a 100644 --- a/package.lisp +++ b/package.lisp @@ -31,8 +31,8 @@ #:urel #:ucoc #:usty #:uxw #:uxnw #:uxns #:lexterm #:labr #:lagr #:lcmp #:lmod #:lnom #:lprn #:lprp #:lspl #:ltrm #:ltyp #:lwd #:sdef #:sstr #:sstre1 #:sstre2 - #:sty #:tui #:def #:sab #:srl #:tty #:rank #:supres #:atn #:atv #:vcui - #:rcui #:vsab #:code #:saui :scui :sdui + #:sty #:tui #:def #:sab #:srl #:tty #:rank #:suppres #:atn #:atv #:vcui + #:rcui #:vsab #:code #:saui #:scui #:sdui #:ispref #:rl #:sty2 #:ui #:ui2 #:ui3 #:eui #:bas #:eui2 #:bas2 #:rui #:cui #:aui #:lui #:sui #:wd #:lat #:nstr :cuilist #:rsab #:lat @@ -40,6 +40,7 @@ #:s#so #:s#cxt #:pfstr #:pfstr2 #:lrl #:def #:ts #:cui1 #:cui2 #:rela #:sl #:mg #:rel #:soc #:cot #:cof #:coa #:isn #:fr #:un #:sna #:soui #:hcd #:stt #:str + #:kpfeng :cvf ;; From class-support.lisp #:ucon-has-tui @@ -89,6 +90,7 @@ #:suistr #:print-umlsclass #:find-ucon-cui #:make-ucon-cui + #:find-uconso-cui #:find-ucon-lui #:find-ucon-sui #:find-ucon-cuisui diff --git a/sql-classes.lisp b/sql-classes.lisp index 20ef37e..54519a0 100644 --- a/sql-classes.lisp +++ b/sql-classes.lisp @@ -230,7 +230,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (make-instance 'ucon :cui cui))) (defun find-ucon-cui (cui &key (srl *current-srl*) without-pfstr) - "Find ucon for a cui" + "Find ucon for a cui. If set SAB, the without-pfstr is on by default" (ensure-cui-integer cui) (unless cui (return-from find-ucon-cui nil)) @@ -246,6 +246,20 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (make-instance 'ucon :cui cui :pfstr str :lrl kcuilrl)))) +(defun find-uconso-cui (cui &key (srl *current-srl*)) + "Find ucon for a cui. If set SAB, the without-pfstr is on by default" + (ensure-cui-integer cui) + (unless cui (return-from find-uconso-cui nil)) + + (collect-umlisp-query (mrconso (lat ts lui stt sui ispref aui saui scui sdui sab tty code str + srl suppress cvf kpfeng kcuisui kcuilui kcuilrl + kluilrl ksuilrl) srl cui cui) + (make-instance 'uconso :cui cui :lat lat :ts ts :lui lui :stt stt :sui sui :ispref ispref + :aui aui :saui saui :scui scui :sdui sdui :sab sab :tty tty :code code + :str str :srl srl :suppress suppress :cvf cvf :kpfeng kpfeng + :kcuisui kcuisui :kcuilui kcuilui :kcuilrl kcuilrl :kluilrl kluilrl + :ksuilrl ksuilrl))) + (defun find-pfstr-cui (cui &key (srl *current-srl*)) "Find preferred string for a cui" (ensure-cui-integer cui) @@ -725,6 +739,43 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" :lrl 'klrl :order '(cui asc)) (find-ucon-cui cui :srl srl))) +(defun find-ucon-word-sab (word &key sab (srl *current-srl*) (like nil)) + "Return list of ustr that match word in matching SAB. Optionally, use SQL's LIKE syntax" + (let ((query (format nil "SELECT c.cui FROM MRCONSO c,MRXW_ENG x WHERE x.WD ~A '~A' AND x.cui=c.cui AND ~A ~A" + (if like "LIKE" "=") + (clsql-sys::sql-escape-quotes word) + (typecase sab + (stringp + (format nil " c.sab='" (clsql-sys::sql-escape-quotes sab))) + (cons + (format nil " c.sab IN (~('~A'~^,~))" + (mapcar 'clsql-sys::sql-escape-quotes sab))) + (t + (error "SAB missing"))) + (if srl (format nil "AND KCUILRL <= ~D" srl) "")))) + (loop for tuple in (mutex-sql-query query) + collect (make-instance 'ucon (first tuple))))) + +(defun find-ustr-word-sab (word &key sab (srl *current-srl*) (like nil)) + "Return list of ustr that match word in matching SAB. Optionally, use SQL's LIKE syntax" + (let ((query (format nil "SELECT c.sui,c.cui,c.lui,c.str,c.lrl,c.stt,c.suppress,c.cuisui FROM MRCONSO c,MRXW_ENG x WHERE x.WD ~A '~A' AND x.cui=c.cui AND x.lui=c.lui AND x.sui=c.sui AND ~A ~A" + (if like "LIKE" "=") + (clsql-sys::sql-escape-quotes word) + (typecase sab + (stringp + (format nil " c.sab='" (clsql-sys::sql-escape-quotes sab))) + (cons + (format nil " c.sab IN (~('~A'~^,~))" + (mapcar 'clsql-sys::sql-escape-quotes sab))) + (t + (error "SAB missing"))) + (if srl (format nil "AND KCUILRL <= ~D" srl) "")))) + (loop for tuple in (mutex-sql-query query) + collect (destructuring-bind (sui cui lui str lrl stt suppress cuisui) tuple + (make-instance 'ustr :sui sui :cui cui :lui lui :str str :lrl lrl + :stt stt :suppress suppress :cuisui cuisui))))) + + (defun find-ucon-normalized-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 ('mrxnw_eng '(cui) srl 'nwd word :like like :distinct t @@ -794,10 +845,10 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" ;;; Multiword lookup and score functions (defun find-uobj-multiword (str obj-lookup-fun sort-fun key srl - only-exact-if-match limit) + only-exact-if-match limit &key extra-lookup-args) (let ((uobjs '())) (dolist (word (delimited-string-to-list str #\space)) - (setq uobjs (append uobjs (funcall obj-lookup-fun word :srl srl)))) + (setq uobjs (append uobjs (apply obj-lookup-fun word :srl srl extra-lookup-args)))) (let ((sorted (funcall sort-fun str (delete-duplicates uobjs :test #'= :key key)))) @@ -816,9 +867,14 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (defun find-ucon-multiword (str &key (srl *current-srl*) (only-exact-if-match t) - limit) - (find-uobj-multiword str #'find-ucon-word #'sort-score-pfstr-str - #'cui srl only-exact-if-match limit)) + limit + sab) + (if sab + (find-uobj-multiword str #'find-ucon-word-sab #'sort-score-pfstr-str + #'cui srl only-exact-if-match limit + :extra-lookup-args (list :sab sab)) + (find-uobj-multiword str #'find-ucon-word #'sort-score-pfstr-str + #'cui srl only-exact-if-match limit))) (defun find-uterm-multiword (str &key (srl *current-srl*) (only-exact-if-match t) @@ -828,9 +884,14 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (defun find-ustr-multiword (str &key (srl *current-srl*) (only-exact-if-match t) - limit) - (find-uobj-multiword str #'find-ustr-word #'sort-score-ustr-str - #'sui srl only-exact-if-match limit)) + limit + sab) + (if sab + (find-uobj-multiword str #'find-ustr-word-sab #'sort-score-ustr-str + #'sui srl only-exact-if-match limit + :extra-lookup-args (list :sab sab)) + (find-uobj-multiword str #'find-ustr-word #'sort-score-ustr-str + #'sui srl only-exact-if-match limit))) (defun sort-score-pfstr-str (str uobjs) "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr" -- 2.34.1