r11168: add cdist-metric

diff --git a/class-support.lisp b/class-support.lisp
index 1d3f96d0902ba0a5f909812b154af04f8d9948c8..d1172022645d2e0ddb9fcead2236158a9c89e3d8 100644 (file)
--- a/class-support.lisp
+++ b/class-support.lisp
@@ -370,68 +370,80 @@
 (defun cdist-ancestors (anc1 anc2)
   (let ((shareds (shared-cuis anc1 anc2)))
     (let ((min most-positive-fixnum)
-          (cui-min nil))
+          (cui-min nil)
+          (path-min nil))
       (declare (fixnum min))
       (dolist (shared shareds)
-        (let* ((d1 (ancestor-distance shared anc1))
-               (d2 (ancestor-distance shared anc2))
-               (dtotal (+ d1 d2)))
-          (declare (fixnum d1 d2 dtotal))
-          (when (< dtotal min)
-            (setq min dtotal
-                  cui-min shared))))
-      (values min cui-min))))
-
-(defun cdist (c1 c2 &key sab include-rb)
-  (let* ((anc1 (ucon-ancestors c1 :sab sab :include-rb include-rb))
-         (anc2 (ucon-ancestors c2 :sab sab :include-rb include-rb)))
-    (multiple-value-bind (min cui)
-        (cdist-ancestors anc1 anc2)
+        (multiple-value-bind (d1 p1) (ancestor-distance shared anc1)
+          (multiple-value-bind (d2 p2) (ancestor-distance shared anc2)
+            (let ((dtotal (+ d1 d2)))
+              (declare (fixnum d1 d2 dtotal))
+              (when (< dtotal min)
+                (format t "~D ~D ~D ~S ~S~%" d1 d2 dtotal p1 p2)
+                (setq min dtotal
+                      cui-min shared
+                      path-min (append p1 (cdr (reverse p2)))
+                      ))))))
+      (values min cui-min path-min))))
+
+(defun cdist-metric (c1 c2 &key sab include-rb full-ucon (srl *current-srl*))
+  (let* ((anc1 (ucon-ancestors c1 :sab sab :include-rb include-rb :full-ucon full-ucon :srl srl))
+         (anc2 (ucon-ancestors c2 :sab sab :include-rb include-rb :full-ucon full-ucon :srl srl)))
+    (multiple-value-bind (min cui path)
+        (cdist-ancestors (list* c1 anc1) (list* c2 anc2))
       (if cui
-          (values min cui)
-        (values nil nil)))))
+          (values min cui (append (list c1) path (unless (eql (cui (car (last path))) (cui c2))
+                                                   (list c2))))
+        (values nil nil nil)))))
                
 
-(defun ancestor-distance (cui ancestors &key (distance 0))
+(defun ancestor-distance (cui ancestors &key (distance 0) path)
   (cond
    ((null ancestors)
     nil)
    ((atom ancestors)
     (when (eql cui (cui ancestors))
-      distance))
+      (values distance (nreverse (list* ancestors path)))))
    ((atom (car ancestors))
     (if (eql cui (cui (car ancestors)))
-        distance
-      (ancestor-distance cui (cdr ancestors) :distance distance)))
+        (values distance (nreverse (list* (car ancestors) path)))
+      (ancestor-distance cui (cdr ancestors) :distance distance :path (list* (car ancestors) path))))
    (t
-    (let ((min most-positive-fixnum))
+    (let ((%min most-positive-fixnum)
+          %path)
       (dolist (a ancestors)
-        (let ((d (ancestor-distance cui a :distance (1+ distance))))
-          (when (and d (< d min))
-            (setq min d))))
-      (when (< min most-positive-fixnum)
-        min)))))
+        (multiple-value-bind (d p) (ancestor-distance cui a :distance (1+ distance) :path path)
+          (when (and d (< d %min))
+            (setq %min d
+                  %path p))))
+      (when (< %min most-positive-fixnum)
+        (values %min %path))))))
 
-    
         
-(defun ucon-ancestors (ucon &key sab include-rb ancestors)
+(defun ucon-ancestors (ucon &key sab include-rb ancestors full-ucon (srl *current-srl*))
   "Returns a list of ancestor lists for a concept"
-  (let* ((parent-rels (append (filter-urels-by-rel (s#rel ucon) "par")
-                              (when include-rb
-                                (filter-urels-by-rel (s#rel ucon) "rb"))))
-         (parents nil))
-    (when sab
-      (setq parent-rels (delete-if-not
-                        (lambda (rel) (string-equal sab (sab rel)))
-                        parent-rels)))
+  (unless ucon (return-from ucon-ancestors nil))
+  (let ((parent-rels (find-urel-cui
+                      (cui ucon)
+                      :without-pfstr2 t
+                      :srl srl
+                      :filter (concatenate 'string
+                                (if sab (format nil "SAB='~A' AND " sab) "")
+                                (if include-rb
+                                    "(REL='RB' OR REL='PAR')"
+                                  "REL='PAR'"))))
+        (parents nil))
     (dolist (rel parent-rels)
-      (let ((parent (find-ucon-cui (cui2 rel))))
-        ;;(format t "~S ~S ~S ~S~%" rel ucon parent ancestors)
+      (let ((parent (if full-ucon
+                        (find-ucon-cui (cui2 rel))
+                      (make-ucon-cui (cui2 rel)))))
+        ;; (format t "~S ~S ~S ~S~%" rel ucon parent ancestors)
         (unless (is-ucon-in-ancestors parent ancestors)
           (push
            (list*
             parent
-            (ucon-ancestors parent :sab (sab rel) :ancestors (append (list parent) ancestors)))
+            (ucon-ancestors parent :sab (sab rel) :ancestors (append (list parent) ancestors)
+                            :full-ucon full-ucon))
            parents))))
     (nreverse parents)))
 

diff --git a/package.lisp b/package.lisp
index 18cbc61e2e2722619ca31fa12eaf016cf4ddbbf2..1aeef5e92ba04e00be3fcfc7f2b1ab62fd5fa95c 100644 (file)
--- a/package.lisp
+++ b/package.lisp
@@ -46,7 +46,7 @@
    #:english-term-p #:remove-non-english-terms #:remove-english-terms
    #:fmt-cui #:fmt-tui #:fmt-sui #:fmt-eui #:fmt-tui
    #:display-con #:display-term #:display-str
-   #:pfstr #:pf-ustr
+   #:pfstr #:pf-ustr #:cdist-metric
    #:cui-p #:lui-p #:sui-p #:tui-p #:eui-p
    #:rel-abbr-info #:filter-urels-by-rel
    #:ucon-ancestors #:ucon-parents
@@ -90,7 +90,6 @@
    #:suistr
    #:print-umlsclass
    #:find-ucon-cui
-   #:find-ucon-cui-sans-pfstr
    #:find-ucon-lui
    #:find-ucon-sui
    #:find-ucon-cuisui

diff --git a/parse-rrf.lisp b/parse-rrf.lisp
index 4e23fb7a6c4adba2dce167837b34d80a1f475209..4076dc7c47635615d12b3813d2beb2030922f814 100644 (file)
--- a/parse-rrf.lisp
+++ b/parse-rrf.lisp
@@ -220,7 +220,7 @@
       ("SUI" "MRCONSO") ("SAUI" "MRCONSO") ("CODE" "MRCONSO")
       ("SCUI" "MRCONSO")
       ("CUI" "MRDEF")
-      ("CUI1" "MRREL") ("CUI2" "MRREL")
+      ("CUI1" "MRREL") ("CUI2" "MRREL") ("SAB" "MRREL")
       ("RUI" "MRREL") ("AUI1" "MRREL") ("AUI2" "MRREL")
       ("CUI" "MRSAT") ("LUI" "MRSAT") ("SUI" "MRSAT")
       ("METAUI" "MRSAT") ("ATN" "MRSAT")

diff --git a/sql-classes.lisp b/sql-classes.lisp
index f6f306ecb204ce8162f92bcf39b9dad8d01a5d3c..6a566f2570d677eb2dff9662439c643c00bcd611 100644 (file)
--- a/sql-classes.lisp
+++ b/sql-classes.lisp
@@ -224,25 +224,27 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
     (setq ,eui (parse-eui ,eui))
     ,eui))
 
-(defun find-ucon-cui (cui &key (srl *current-srl*))
+(defun make-ucon-cui (cui)
+  (ensure-cui-integer cui)
+  (when cui
+    (make-instance 'ucon :cui cui)))
+  
+(defun find-ucon-cui (cui &key (srl *current-srl*) without-pfstr)
   "Find ucon for a cui"
   (ensure-cui-integer cui)
   (unless cui (return-from find-ucon-cui nil))
 
-  (or
-   (collect-umlisp-query (mrconso (kcuilrl str) srl cui cui :single t :filter "KPFENG=1")
-    (make-instance 'ucon :cui cui :pfstr str
-                   :lrl kcuilrl))
-   (collect-umlisp-query (mrconso (kcuilrl str) srl cui cui :single t)
-    (make-instance 'ucon :cui cui :pfstr str
-                   :lrl kcuilrl))))
-
-(defun find-ucon-cui-sans-pfstr (cui &key (srl *current-srl*))
-  "Find ucon for a cui"
-  (ensure-cui-integer cui)
-  (collect-umlisp-query (mrconso (kcuilrl) srl cui cui :single t)
-    (make-instance 'ucon :cui cui :lrl (ensure-integer kcuilrl)
-                  :pfstr nil)))
+  (if without-pfstr
+      (collect-umlisp-query (mrconso (kcuilrl) srl cui cui :single t)
+                            (make-instance 'ucon :cui cui :lrl (ensure-integer kcuilrl)
+                                           :pfstr nil)))
+   (or
+     (collect-umlisp-query (mrconso (kcuilrl str) srl cui cui :single t :filter "KPFENG=1")
+        (make-instance 'ucon :cui cui :pfstr str
+                       :lrl kcuilrl))
+     (collect-umlisp-query (mrconso (kcuilrl str) srl cui cui :single t)
+        (make-instance 'ucon :cui cui :pfstr str
+                       :lrl kcuilrl))))
 
 (defun find-pfstr-cui (cui &key (srl *current-srl*))
   "Find preferred string for a cui"
@@ -380,15 +382,19 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
                            :distinct t)
     (make-instance 'usty :tui (ensure-integer tui) :sty sty)))
 
-(defun find-urel-cui (cui &key (srl *current-srl*))
+(defun find-urel-cui (cui &key (srl *current-srl*) filter without-pfstr2)
   "Return a list of urel for cui"
   (ensure-cui-integer cui)
   (collect-umlisp-query (mrrel (aui1 rel stype1 cui2 aui2 stype2 rela rui srui sab sl rg dir suppress cvf)
-                              srl cui1 cui :lrl "KSRL")
-    (make-instance 'urel :cui1 cui :aui1 (ensure-integer aui1) :stype1 stype1 :rel rel
-                  :cui2 (ensure-integer cui2) :aui2 (ensure-integer aui2) :stype2 stype2
-                  :rui (ensure-integer rui) :srui srui :rela rela :sab sab :sl sl :rg rg :dir dir
-                  :suppress suppress :cvf cvf :pfstr2 (find-pfstr-cui cui2))))
+                              srl cui1 cui :lrl "KSRL" :filter filter)
+    (let ((rel                        
+      (make-instance 'urel :cui1 cui :aui1 (ensure-integer aui1) :stype1 stype1 :rel rel
+                     :cui2 (ensure-integer cui2) :aui2 (ensure-integer aui2) :stype2 stype2
+                     :rui (ensure-integer rui) :srui srui :rela rela :sab sab :sl sl :rg rg :dir dir
+                     :suppress suppress :cvf cvf)))
+      (unless without-pfstr2
+        (setf (slot-value rel 'pfstr2) (find-pfstr-cui cui2)))
+      rel)))
 
 (defun find-urel-rui (rui &key (srl *current-srl*))
   "Return the urel for a rui"