From 16330812b9a0fef2394d2a45889ab04bec5d3859 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Mon, 21 Jul 2003 00:53:27 +0000 Subject: [PATCH] r5354: *** empty log message *** --- class-support.lisp | 34 +++++++++++++++++++++-- composite.lisp | 4 +-- package.lisp | 3 +- parse-2002.lisp | 14 +--------- sql-classes.lisp | 69 +++++++++++++++++----------------------------- 5 files changed, 62 insertions(+), 62 deletions(-) diff --git a/class-support.lisp b/class-support.lisp index b106046..3245a1f 100644 --- 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 e4fbcfe..230a33b 100644 --- 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 f53f100..3829187 100644 --- 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 53c6d63..ef08f4c 100644 --- 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 bdaa025..3af923d 100644 --- 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 -- 2.34.1