r11612: rework find-*-sab functions to reuse main find-* function with SAB as an...

diff --git a/package.lisp b/package.lisp
index 45bb26c01a2156cce0dedee03eee0018f7390e06..604ea7dffad8b353fede303f2a8221ca52ef8e1a 100644 (file)
--- a/package.lisp
+++ b/package.lisp
@@ -90,6 +90,8 @@
    #:print-umlsclass
    #:find-ucon-cui #:make-ucon-cui
    #:find-uconso-cui
+   #:find-uconso-sui
+   #:find-uconso-code
    #:find-ucon-lui
    #:find-ucon-sui
    #:find-ucon-cuisui

diff --git a/sql-classes.lisp b/sql-classes.lisp
index d434e94d308f3cd5193429f6ab5a0035b1f6e57d..e0f6c43e0daea72a49a777b3c82a89be58ad89ce 100644 (file)
--- a/sql-classes.lisp
+++ b/sql-classes.lisp
@@ -246,46 +246,31 @@ 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*))
+(defun find-uconso-cui (cui &key sab (srl *current-srl*))
   "Find uconso for a cui."
   (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-uconso-cui-sab (cui sab &key (srl *current-srl*))
-  "Find uconso for a cui. If set SAB, the without-pfstr is on by default"
-  (ensure-cui-integer cui)
-  (unless (and cui (stringp sab))
-    (return-from find-uconso-cui-sab 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
-                                      :filter (concatenate 'string "SAB='" sab "'"))
+                                      :filter (if sab (concatenate 'string "SAB='" sab "'") nil))
     (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-uconso-sui-sab (sui sab &key (srl *current-srl*))
+(defun find-uconso-sui (sui &key sab (srl *current-srl*))
   "Find uconso for a sui. If set SAB, the without-pfstr is on by default"
   (ensure-sui-integer sui)
   (unless (and sui (stringp sab))
-    (return-from find-uconso-sui-sab nil))
+    (return-from find-uconso-sui nil))
 
   (collect-umlisp-query (mrconso (cui lat ts lui stt sui ispref aui saui scui sdui sab tty code str
                                       srl suppress cvf kpfeng kcuisui kcuilui kcuilrl
                                       kluilrl ksuilrl) srl sui sui
-                                      :filter (concatenate 'string "SAB='" sab "'"))
+                                      :filter (if sab (concatenate 'string "SAB='" sab "'") nil))
     (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
@@ -754,79 +739,66 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
   (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
-                                    :lrl 'klrl :order '(cui asc))
-    (find-ucon-cui cui :srl srl)))
-
-(defun find-uconso-word (word &key (srl *current-srl*) (like nil))
-  "Return list of uconso objects that match word. Optionally, use SQL's LIKE syntax"
-  (collect-umlisp-query-eval ('mrxw_eng '(cui) srl 'wd word :like like :distinct t
-                                    :lrl 'klrl :order '(cui asc))
-    (find-uconso-cui cui :srl srl)))
+(defun find-uconso-code (code &key sab (srl *current-srl*) (like nil))
+  "Return list of uconso objects that match code. Optional, filter for SAB. Optionally, use SQL's LIKE syntax"
+  (collect-umlisp-query (mrconso (sui sab) srl code code :like like :distinct t
+                                 :lrl klrl
+                                 :filter (if sab (concatenate 'string "SAB='" sab "'") nil))
+    (find-uconso-sui sui :sab sab :srl srl)))
 
 (defun mrconso-query-word-cui (word sab srl like)
-  (format nil "SELECT DISTINCT c.cui FROM MRCONSO c,MRXW_ENG x WHERE x.WD  ~A '~A' AND x.cui=c.cui AND ~A ~A"
-          (if like "LIKE" "=")
+  (format nil "SELECT DISTINCT c.cui FROM MRCONSO c,MRXW_ENG x WHERE x.WD~A'~A' AND x.cui=c.cui~A~A"
+          (if like " LIKE " "=")
           (clsql-sys::sql-escape-quotes word)
           (etypecase sab
             (string
-             (format nil " c.sab='~A'" (clsql-sys::sql-escape-quotes sab)))
+             (format nil " AND c.sab='~A'" (clsql-sys::sql-escape-quotes sab)))
             (cons
-             (format nil " c.sab IN (~{'~A'~^,~})"
+             (format nil " AND c.sab IN (~{'~A'~^,~})"
                      (mapcar 'clsql-sys::sql-escape-quotes sab)))
             (null
-             (error "SAB missing")))
-          (if srl (format nil "AND KCUILRL <= ~A" srl) "")))
+             ""))
+          (if srl (format nil " AND KCUILRL <= ~A" srl) "")))
 
 (defun mrconso-query-word-sui (word sab srl like)
-  (format nil "SELECT DISTINCT c.sui FROM MRCONSO c,MRXW_ENG x WHERE x.WD  ~A '~A' AND x.sui=c.sui AND ~A ~A"
-          (if like "LIKE" "=")
+  (format nil "SELECT DISTINCT c.sui FROM MRCONSO c,MRXW_ENG x WHERE x.WD~A'~A' AND x.sui=c.sui~A~A"
+          (if like " LIKE " "=")
           (clsql-sys::sql-escape-quotes word)
           (etypecase sab
             (string
-             (format nil " c.sab='~A'" (clsql-sys::sql-escape-quotes sab)))
+             (format nil " AND c.sab='~A'" (clsql-sys::sql-escape-quotes sab)))
             (cons
-             (format nil " c.sab IN (~{'~A'~^,~})"
+             (format nil " AND c.sab IN (~{'~A'~^,~})"
                      (mapcar 'clsql-sys::sql-escape-quotes sab)))
             (null
-             (error "SAB missing")))
-          (if srl (format nil "AND KCUILRL <= ~A" srl) "")))
-
-(defun find-uconso-word-sab (word &key sab (srl *current-srl*) (like nil))
-  "Return list of uconso that match word in matching SAB. Optionally, use SQL's LIKE syntax"
-  (let ((sui-query (mrconso-query-word-sui word sab srl like))
-        (uconsos nil))
-    (dolist (sui (remove-duplicates (sort (mapcar 'car (mutex-sql-query sui-query)) #'<)))
-      (setq uconsos (nconc uconsos (find-uconso-sui-sab sui sab))))
-    (remove-duplicates uconsos :key 'cui)))
-
-(defun find-ucon-word-sab (word &key sab (srl *current-srl*) (like nil))
-  "Return list of ucon that match word in matching SAB. Optionally, use SQL's LIKE syntax"
-  (let ((query (mrconso-query-word-cui word sab srl like)))
-    (loop for tuple in (mutex-sql-query query)
-          collect (make-instance 'ucon :cui (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
-                         (string
-                          (format nil " c.sab='~A'" (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)))))
+             ""))
+          (if srl (format nil " AND KCUILRL <= ~A" srl) "")))
 
+(defun find-uconso-word (word &key sab (srl *current-srl*) (like nil))
+  "Return list of uconso that match word. Optionally, matching SAB. Optionally, use SQL's LIKE syntax"
+  (cond
+    (sab
+     (let ((sui-query (mrconso-query-word-sui word sab srl like))
+           (uconsos nil))
+       (dolist (sui (remove-duplicates (sort (mapcar 'car (mutex-sql-query sui-query)) #'<)))
+         (setq uconsos (nconc uconsos (find-uconso-sui sui :sab sab))))
+       (remove-duplicates uconsos :key 'cui)))
+    (t
+     (collect-umlisp-query-eval ('mrxw_eng '(cui) srl 'wd word :like like :distinct t
+                                           :lrl 'klrl :order '(cui asc))
+       (find-uconso-cui cui :srl srl)))))
+
+(defun find-ucon-word (word &key sab (srl *current-srl*) (like nil))
+  "Return list of ucon that match word in matching SAB. Optionally, use SQL's LIKE syntax"
+  (cond
+    (sab
+     (let ((query (mrconso-query-word-cui word sab srl like)))
+       (loop for tuple in (mutex-sql-query query)
+             collect (make-instance 'ucon :cui (first tuple)))))
+    (t
+     (collect-umlisp-query-eval ('mrxw_eng '(cui) srl 'wd word :like like :distinct t
+                                           :lrl 'klrl :order '(cui asc))
+       (find-ucon-cui cui :srl srl)))))
 
 (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"
@@ -852,11 +824,30 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
                                         :lrl 'klrl :order '(cui asc))
                             sui))
 
-(defun find-ustr-word (word &key (srl *current-srl*))
-  "Return list of ustrs that match word"
-  (collect-umlisp-query (mrxw_eng (cui sui) srl wd word :lrl klrl
-                              :order (cui asc sui asc))
-    (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl)))
+(defun find-ustr-word (word &key sab (srl *current-srl*) (like nil))
+  "Return list of ustr that match word in matching SAB. Optionally, use SQL's LIKE syntax"
+  (cond
+    (sab
+     (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~A~A"
+                          (if like "LIKE" "=")
+                          (clsql-sys::sql-escape-quotes word)
+                          (typecase sab
+                            (string
+                             (format nil " AND c.sab='~A'" (clsql-sys::sql-escape-quotes sab)))
+                            (cons
+                             (format nil " AND c.sab IN (~('~A'~^,~))"
+                                     (mapcar 'clsql-sys::sql-escape-quotes sab)))
+                            (null
+                             ""))
+                          (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)))))
+    (t
+     (collect-umlisp-query (mrxw_eng (cui sui) srl wd word :lrl klrl
+                                     :order (cui asc sui asc))
+       (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl)))))
 
 (defun find-ustr-normalized-word (word &key (srl *current-srl*))
   "Return list of ustrs that match word"
@@ -921,23 +912,17 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
                                     (only-exact-if-match t)
                                      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)))
+  (find-uobj-multiword str #'find-ucon-word #'sort-score-pfstr-str
+                       #'cui srl only-exact-if-match limit
+                       :extra-lookup-args (list :sab sab)))
 
 (defun find-uconso-multiword (str &key (srl *current-srl*)
                                     (only-exact-if-match t)
                                      limit
                                      sab)
-  (if sab
-      (find-uobj-multiword str #'find-uconso-word-sab #'sort-score-pfstr-str
-                           #'cui srl only-exact-if-match limit
-                           :extra-lookup-args (list :sab sab))
-    (find-uobj-multiword str #'find-uconso-word #'sort-score-pfstr-str
-                         #'cui srl only-exact-if-match limit)))
+  (find-uobj-multiword str #'find-uconso-word #'sort-score-pfstr-str
+                       #'cui srl only-exact-if-match limit
+                       :extra-lookup-args (list :sab sab)))
 
 (defun find-uterm-multiword (str &key (srl *current-srl*)
                                      (only-exact-if-match t)
@@ -949,12 +934,9 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
                                     (only-exact-if-match t)
                                      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)))
+  (find-uobj-multiword str #'find-ustr-word #'sort-score-ustr-str
+                       #'sui srl only-exact-if-match limit
+                       :extra-lookup-args (list :sab sab)))
 
 (defun sort-score-pfstr-str (str uobjs)
   "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"

diff --git a/tests/parse.lisp b/tests/parse.lisp
index 9e1670a4802ad2d9c77a1485f3905d199e9e1f6a..83753b4fc1294075bd76ed8b94db0151f9b21464 100644 (file)
--- a/tests/parse.lisp
+++ b/tests/parse.lisp
@@ -43,6 +43,7 @@
        (umlisp::filename-to-tablename "TEST.AB.RRF")
       "TEST_AB")))
 
+;; specific for UMLS2007AA
 (when (probe-file (umlisp::umls-pathname "MRFILES.RRF"))
   (umlisp::ensure-ucols+ufiles)
   (setq
@@ -51,7 +52,7 @@
     *rt-parse*
     '(
       (deftest uparse.1 (length *umls-files*) 63)
-      (deftest uparse.2 (length *umls-cols*) 434)
+      (deftest uparse.2 (length *umls-cols*) 452)
       (deftest uparse.3
          (sort (mapcar #'u::col (umlisp::ucols (umlisp::find-ufile "MRCONSO.RRF")))
           #'string<)