r5354: *** empty log message ***

diff --git a/class-support.lisp b/class-support.lisp
index b106046d2b732387a6c248d5b25f0ffac2940756..3245a1f96154a680b36514786ac689cb7daee95b 100644 (file)
--- a/class-support.lisp
+++ b/class-support.lisp
@@ -7,7 +7,7 @@
 ;;;; Author:       Kevin M. Rosenberg
 ;;;; Date Started: Apr 2000
 ;;;;
-;;;; $Id: class-support.lisp,v 1.17 2003/07/19 20:32:48 kevin Exp $
+;;;; $Id: class-support.lisp,v 1.18 2003/07/21 00:53:27 kevin Exp $
 ;;;;
 ;;;; This file, part of UMLisp, is
 ;;;;    Copyright (c) 2000-2003 by Kevin M. Rosenberg, M.D.
@@ -160,6 +160,10 @@
     (when (string= "PF" (stt ustr))
       (return-from pfstr (str ustr)))))
 
+(defmethod pfstr ((ustr ustr))
+  "Return the preferred string for a ustr, which is the string itself"
+  (str ustr))
+
 (defun remove-non-english-terms (uterms)
   (remove-if-not #'english-term-p uterms))
 
@@ -167,7 +171,33 @@
   (remove-if #'english-term-p uterms))
 
 
-#+(or scl cmu)
+(defvar +relationship-abbreviations+
+  '(("RB" "Broader" "has a broader relationship")
+    ("RN" "Narrower" "has a narrower relationship")
+    ("RO" "Other related" "has relationship other than synonymous, narrower, or broader")
+    ("RL" "Like" "the two concepts are similar or 'alike'.  In the current edition of the Metathesaurus, most relationships with this attribute are mappings provided by a source")
+    ("RQ" "Unspecified" "unspecified source asserted relatedness, possibly synonymous")
+    ("SY" "Source Synonymy" "source asserted synonymy")
+    ("PAR" "Parent" "has parent relationship in a Metathesaurus source vocabulary")
+    ("CHD" "Child" "has child relationship in a Metathesaurus source vocabulary")
+    ("SIB" "Sibling" "has sibling relationship in a Metathesaurus source vocabulary")
+    ("AQ" "Allowed" "is an allowed qualifier for a concept in a Metathesaurus source vocabulary")
+    ("QB" "Qualified" "can be qualified by a concept in a Metathesaurus source vocabulary")))
+
+(defvar *rel-info-table* (make-hash-table :size 30 :test 'equal))
+(defvar *is-rel-table-init* nil)
+(unless *is-rel-table-init*
+  (dolist (relinfo +relationship-abbreviations+)
+    (setf (gethash (string-downcase (car relinfo)) *rel-info-table*)
+      (cdr relinfo)))
+  (setq *is-rel-table-init* t))
+
+(defun rel-abbr-info (rel)
+  (nth-value 0 (gethash (string-downcase rel) *rel-info-table*)))
+
+ 
+
+#+(or 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))
     #+cmu
     (let ((cl (pcl:find-class c)))

diff --git a/composite.lisp b/composite.lisp
index e4fbcfe85988ef067e3773660734f94c2569fcdd..230a33bd79bbe6d50e6455bcaebae89a3f8f38a8 100644 (file)
--- a/composite.lisp
+++ b/composite.lisp
@@ -7,7 +7,7 @@
 ;;;; Author:        Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: composite.lisp,v 1.24 2003/06/10 22:30:16 kevin Exp $
+;;;; $Id: composite.lisp,v 1.25 2003/07/21 00:53:27 kevin Exp $
 ;;;;
 ;;;; This file, part of UMLisp, is
 ;;;;    Copyright (c) 2000-2003 by Kevin M. Rosenberg, M.D.
@@ -184,7 +184,7 @@
 (defun find-ucon2_freq-coc-tui-all (tui)
   (find-ucon2_freq-tui-all tui #'find-ucon2-coc-tui))
 
-#+(or cmu scl)
+#+(or scl)
 (dolist (c '(ucon_freq ustr_freq usty_freq usrl_freq))
   (let ((cl #+cmu (pcl:find-class c)
            #+scl (find-class c)))

diff --git a/package.lisp b/package.lisp
index f53f100c4bb5d3bb06184c716b0a612a38b018fe..382918775ab3811a1f2d72cdbdaa7ce0cc6fe367 100644 (file)
--- a/package.lisp
+++ b/package.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: package.lisp,v 1.26 2003/07/19 20:32:48 kevin Exp $
+;;;; $Id: package.lisp,v 1.27 2003/07/21 00:53:27 kevin Exp $
 ;;;;
 ;;;; This file, part of UMLisp, is
 ;;;;    Copyright (c) 2000-2003 by Kevin M. Rosenberg, M.D.
@@ -46,6 +46,7 @@
    #:display-con #:display-term #:display-str
    #:uterm-pfstr
    #:cui-p #:lui-p #:sui-p #:tui-p #:eui-p
+   #:rel-abbr-info
    
    ;; From sql.lisp
    #:umls-sql-user!

diff --git a/parse-2002.lisp b/parse-2002.lisp
index 53c6d6358dae1c471325ac6979db8425492329e5..ef08f4c7c78027c5fb2cd2c3438b9ed29bf0913c 100644 (file)
--- a/parse-2002.lisp
+++ b/parse-2002.lisp
@@ -8,7 +8,7 @@
 ;;;; Author:        Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: parse-2002.lisp,v 1.14 2003/06/11 01:42:03 kevin Exp $
+;;;; $Id: parse-2002.lisp,v 1.15 2003/07/21 00:53:27 kevin Exp $
 ;;;;
 ;;;; This file, part of UMLisp, is
 ;;;;    Copyright (c) 2000-2003 by Kevin M. Rosenberg, M.D.
@@ -254,18 +254,6 @@
       ("VCUI" "MRSAB") ("LAT" "MRSAB"))
   "Columns in files to index")
 
-(defvar +relationship-abbreviations+
-  '(("RB" "Broader" "has a broader relationship")
-    ("RN" "Narrower" "has a narrower relationship")
-    ("RO" "Other related" "has relationship other than synonymous, narrower, or broader")
-    ("RL" "Like" "the two concepts are similar or 'alike'.  In the current edition of the Metathesaurus, most relationships with this attribute are mappings provided by a source")
-    ("RQ" "Unspecified" "unspecified source asserted relatedness, possibly synonymous")
-    ("SY" "Source Synonymy" "source asserted synonymy")
-    ("PAR" "Parent" "has parent relationship in a Metathesaurus source vocabulary")
-    ("CHD" "Child" "has child relationship in a Metathesaurus source vocabulary")
-    ("SIB" "Sibling" "has sibling relationship in a Metathesaurus source vocabulary")
-    ("AQ" "Allowed" "is an allowed qualifier for a concept in a Metathesaurus source vocabulary")
-    ("QB" "Qualified" "can be qualified by a concept in a Metathesaurus source vocabulary")))
 
 (defparameter +custom-index-cols+
   nil

diff --git a/sql-classes.lisp b/sql-classes.lisp
index bdaa025aa50a513ceccda298955565fceb78db6d..3af923d2b1e7c1def2e54282f4cf0c06411275de 100644 (file)
--- a/sql-classes.lisp
+++ b/sql-classes.lisp
@@ -7,7 +7,7 @@
 ;;;; Author:        Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: sql-classes.lisp,v 1.87 2003/06/24 08:49:09 kevin Exp $
+;;;; $Id: sql-classes.lisp,v 1.88 2003/07/21 00:53:27 kevin Exp $
 ;;;;
 ;;;; This file, part of UMLisp, is
 ;;;;    Copyright (c) 2000-2003 by Kevin M. Rosenberg, M.D.
@@ -595,20 +595,34 @@ 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)
+(defun find-uobj-multiword (str obj-lookup-fun sort-fun key srl
+                           only-exact-if-match)
   (let ((uobjs '()))
     (dolist (word (delimited-string-to-list str #\space))
       (setq uobjs (append uobjs (funcall obj-lookup-fun word :srl srl))))
-    (funcall sort-fun str (delete-duplicates uobjs :test #'= :key key))))
+    (let ((sorted 
+          (funcall sort-fun str
+                   (delete-duplicates uobjs :test #'= :key key))))
+      (if (and (plusp (length sorted))
+              only-exact-if-match
+              (multiword-match str (pfstr (first sorted))))
+         (first sorted)
+       sorted))))
     
-(defun find-ucon-multiword (str &key (srl *current-srl*))
-  (find-uobj-multiword str #'find-ucon-word #'sort-score-pfstr-str #'cui srl))
-
-(defun find-uterm-multiword (str &key (srl *current-srl*))
-  (find-uobj-multiword str #'find-uterm-word #'sort-score-pfstr-str #'lui srl))
-
-(defun find-ustr-multiword (str &key (srl *current-srl*))
-  (find-uobj-multiword str #'find-ustr-word #'sort-score-ustr-str #'sui srl))
+(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
+                      #'cui srl only-exact-if-match))
+
+(defun find-uterm-multiword (str &key (srl *current-srl*)
+                                     (only-exact-if-match t))
+  (find-uobj-multiword str #'find-uterm-word #'sort-score-pfstr-str
+                      #'lui srl only-exact-if-match))
+
+(defun find-ustr-multiword (str &key (srl *current-srl*)
+                                    (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"
@@ -626,39 +640,6 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
        scored))
     (mapcar #'car (sort scored #'> :key #'cadr))))
 
-(defun score-multiword-match (s1 s2)
-  "Score a match between two strings with s1 being reference string"
-  (let* ((word-list-1 (delimited-string-to-list s1 #\space))
-        (word-list-2 (delimited-string-to-list s2 #\space))
-        (n1 (length word-list-1))
-        (n2 (length word-list-2))
-        (unmatched n1)
-        (score 0)
-        (nlong 0)
-        (nshort 0)
-        short-list long-list)
-    (declare (fixnum n1 n2 nshort nlong score unmatched))
-    (if (> n1 n2)
-       (progn
-         (setq nlong n1)
-         (setq nshort n2)
-         (setq long-list word-list-1)
-         (setq short-list word-list-2))
-      (progn
-       (setq nlong n2)
-       (setq nshort n1)
-       (setq long-list word-list-2)
-       (setq short-list word-list-1)))
-    (decf score (- nlong nshort)) ;; reduce score for extra words
-    (dotimes (iword nshort)
-      (declare (fixnum iword))
-      (kmrcl:aif (position (nth iword short-list) long-list :test #'string-equal)
-          (progn
-            (incf score (- 10 (abs (- kmrcl::it iword))))
-            (decf unmatched))))
-    (decf score (* 2 unmatched))
-    score))
-
 
 ;;; LEX SQL functions