From 573f637369291414feb365121216b6b53ae6aaa7 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sun, 17 Sep 2006 03:58:14 +0000 Subject: [PATCH] r11168: add cdist-metric --- class-support.lisp | 92 ++++++++++++++++++++++++++-------------------- package.lisp | 3 +- parse-rrf.lisp | 2 +- sql-classes.lisp | 48 +++++++++++++----------- 4 files changed, 81 insertions(+), 64 deletions(-) diff --git a/class-support.lisp b/class-support.lisp index 1d3f96d..d117202 100644 --- 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 18cbc61..1aeef5e 100644 --- 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 4e23fb7..4076dc7 100644 --- 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 f6f306e..6a566f2 100644 --- 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" -- 2.34.1