X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql-classes.lisp;h=52b9ce8873e9f4646b4200b205dbd6460b66262a;hb=750cc1891b279fb8fa6a9e4e8bd699a0cb874485;hp=904e77d30a24f2ddcc09d54a5bf6dc5e246fdc56;hpb=a4851b680b8430b9792d1e86318657de16cf0a96;p=umlisp.git

diff --git a/sql-classes.lisp b/sql-classes.lisp
index 904e77d..52b9ce8 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.86 2003/06/24 00:27:59 kevin Exp $
+;;;; $Id: sql-classes.lisp,v 1.89 2003/07/21 09:46:22 kevin Exp $
 ;;;;
 ;;;; This file, part of UMLisp, is
 ;;;;    Copyright (c) 2000-2003 by Kevin M. Rosenberg, M.D.
@@ -76,10 +76,11 @@
 
 
 (defmacro umlisp-query (table fields srl where-name where-value
-		     &key (lrl "KCUILRL") single distinct order like)
+		     &key (lrl "KCUILRL") single distinct order like
+			(query-cmd 'mutex-sql-query))
   "Query the UMLisp database. Return a list of umlisp objects whose name
 is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
-  `(mutex-sql-query
+  `(,query-cmd
     (query-string ,table ,fields ,srl ,where-name ,where-value 
      :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like)))
 
@@ -94,8 +95,8 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
 ;; only WHERE-VALUE and SRL are evaluated
 (defmacro collect-umlisp-query ((table fields srl where-name where-value
 				    &key (lrl "KCUILRL") distinct single
-				    order like)
-			     &body body)
+				    order like (query-cmd 'mutex-sql-query))
+				&body body)
   (let ((value (gensym))
 	(r (gensym))) 
     (if single
@@ -103,7 +104,8 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
 		(tuple (car (umlisp-query ,table ,fields ,srl ,where-name ,value
 					  :lrl ,lrl :single ,single
 					  :distinct ,distinct :order ,order
-					  :like ,like))))
+					  :like ,like
+					  :query-cmd ,query-cmd))))
 	  ,@(unless where-name `((declare (ignore ,value))))
 	  (when tuple
 		(destructuring-bind ,fields tuple
@@ -565,15 +567,15 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
 
 (defun find-uterm-word (word &key (srl *current-srl*))
   "Return list of uterms that match word"
-  (collect-umlisp-query (mrxw_eng (cui sui) srl wd word :lrl klrl
-			       :order (cui asc sui asc))
-    (find-uterm-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl)))
+  (collect-umlisp-query (mrxw_eng (cui lui) srl wd word :lrl klrl
+			       :order (cui asc lui asc))
+    (find-uterm-cuilui (ensure-integer cui) (ensure-integer lui) :srl srl)))
 
 (defun find-uterm-normalized-word (word &key (srl *current-srl*))
   "Return list of uterms that match word"
-  (collect-umlisp-query (mrxnw_eng (cui sui) srl nwd word :lrl klrl
-				 :order (cui asc sui asc))
-    (find-uterm-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl)))
+  (collect-umlisp-query (mrxnw_eng (cui lui) srl nwd word :lrl klrl
+				 :order (cui asc lui asc))
+    (find-uterm-cuilui (ensure-integer cui) (ensure-integer lui) :srl srl)))
 
 (defun find-ucon-noneng-word (word &key (srl *current-srl*) (like nil))
   "Return list of ucons that match non-english word"
@@ -595,25 +597,38 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
 
 ;;; Multiword lookup and score functions
 
-(defun find-ucon-multiword (str &key (srl *current-srl*))
-  "Return sorted list of ucon's that match a multiword string"
-  (let* ((words (delimited-string-to-list str #\space))
-	 (ucons '()))
-    (dolist (word words)
-      (setq ucons (append ucons (find-ucon-word word :srl srl))))
-    (sort-score-ucon-str str (delete-duplicates ucons :test #'eql :key #'cui))))
-
-(defun find-ustr-multiword (str &key (srl *current-srl*))
-  "Return sorted list of ustr's that match a multiword string"
-  (let* ((words (delimited-string-to-list str #\space))
-	 (ustrs '()))
-    (dolist (word words)
-      (setq ustrs (append ustrs (find-ustr-word word :srl srl))))
-    (sort-score-ustr-str str (delete-duplicates ustrs :test #'eql :key #'cui))))
+(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))))
+    (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*)
+				     (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-ucon-str (str ucons)
+(defun sort-score-pfstr-str (str uobjs)
   "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"
-  (sort-score-umlsclass-str ucons str #'pfstr))
+  (sort-score-umlsclass-str uobjs str #'pfstr))
 
 (defun sort-score-ustr-str (str ustrs)
   "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"
@@ -627,39 +642,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
 
@@ -768,3 +750,98 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
 (defun find-sstr-styrl (styrl)
   (collect-umlisp-query (srstr (rl sty_rl2 ls) nil styrl styrl)
     (make-instance 'sstr :styrl styrl :rl rl :styrl2 sty_rl2 :ls ls)))
+
+
+;;; **************************
+;;; Local Classes
+;;; **************************
+
+
+(defun make-ustats ()
+  (with-sql-connection (conn)
+    (sql-execute "drop table if exists USTATS" conn)
+    (sql-execute "create table USTATS (NAME varchar(160), COUNT bigint, SRL integer)" conn)
+    
+    (dotimes (srl 4)
+      (insert-ustats-count conn "Concept Count" "MRCON" "distinct CUI" "KCUILRL" srl)
+      (insert-ustats-count conn "Term Count" "MRCON" "distinct KCUILUI" "KCUILRL" srl)
+      (insert-ustats-count conn "Distinct Term Count" "MRCON" "distinct LUI" "KLUILRL" srl)
+      (insert-ustats-count conn "String Count" "MRCON" "*" "LRL" srl)
+      (insert-ustats-count conn "Distinct String Count" "MRCON" "distinct SUI" "LRL" srl)
+      (insert-ustats-count conn "Associated Expression Count" "MRATX" "*" "KSRL" srl)
+      (insert-ustats-count conn "Context Count" "MRCXT" "*" "KSRL" srl)
+      (insert-ustats-count conn "Co-occuring Concept Count" "MRCOC" "*" "KLRL" srl)
+      (insert-ustats-count conn "Definition Count" "MRDEF" "*" "KSRL" srl)
+      (insert-ustats-count conn "Locator Count" "MRLO" "*" "KLRL" srl)
+      (insert-ustats-count conn "Rank Count" "MRRANK" "*" "KSRL" srl)
+      (insert-ustats-count conn "Relationship Count" "MRREL" "*" "KSRL" srl)
+      (insert-ustats-count conn "Semantic Type Count" "MRSTY" "*" "KLRL" srl)
+      (insert-ustats-count conn "Simple Attribute Count" "MRSAT" "*" "KSRL" srl)
+      (insert-ustats-count conn "Source Count" "MRSO" "*" "SRL" srl)
+      (insert-ustats-count conn "Word Index Count" "MRXW_ENG" "*" "KLRL" srl)
+      (insert-ustats-count conn "Normalized Word Index Count" "MRXNW_ENG" "*" "KLRL" srl)
+      (insert-ustats-count conn "Normalized String Index Count" "MRXNS_ENG" "*" "KLRL" srl)
+      (insert-ustats-count conn "Bonus Attribute Name Count" "BONUS_ATN" "*" nil srl)
+      (insert-ustats-count conn "Bonus Relationship Count" "BONUS_REL" "*" nil srl)
+      (insert-ustats-count conn "Bonus Source Abbreviation Count" "BONUS_SAB" "*" nil srl)
+      (insert-ustats-count conn "Bonus Term Type Count" "BONUS_TTY" "*" nil srl))
+    (sql-execute "create index USTATS_SRL on USTATS (SRL)" conn))
+  (find-ustats-all))
+
+(defun insert-ustats-count (conn name table count-variable srl-control srl)
+  (insert-ustats conn name (find-count-table conn table srl count-variable srl-control) srl))
+
+(defun find-count-table (conn table srl count-variable srl-control)
+  (cond
+   ((stringp srl-control)
+    (ensure-integer 
+     (caar (sql-query (format nil "select count(~a) from ~a where ~a <= ~d" 
+			      count-variable table srl-control srl)
+		      conn))))
+   ((null srl-control)
+    (ensure-integer
+     (caar (sql-query (format nil "select count(~a) from ~a" 
+			      count-variable table )
+		      conn))))
+   (t
+    (error "Unknown srl-control")
+    0)))
+
+(defun insert-ustats (conn name count srl)
+  (sql-execute (format nil "insert into USTATS (name,count,srl) values ('~a',~d,~d)" 
+		       name count (if srl srl 3)) 
+	       conn))
+
+(defun find-ustats-all (&key (srl *current-srl*))
+  (collect-umlisp-query (ustats (name count srl) nil srl srl
+				   :order (name asc))
+   (make-instance 'ustats :name name :hits (ensure-integer count)
+		  :srl (ensure-integer srl))))
+
+(defun find-ustats-srl (srl)
+  (collect-umlisp-query (ustats (name count) nil srl srl :order (name asc))
+			   (make-instance 'ustats :name name :hits (ensure-integer count))))
+
+
+
+(defun find-bsab-sab (sab)
+ (collect-umlisp-query (bonus_sab (name count) nil sab sab :single t)
+     (make-instance 'bsab :sab sab :name name :hits (ensure-integer count))))
+
+(defun find-bsab-all ()
+ (collect-umlisp-query (bonus_sab (sab name count) nil nil nil :order (sab asc))
+     (make-instance 'bsab :sab sab :name name :hits (ensure-integer count))))
+
+(defun find-btty-tty (tty)
+ (:collect-umlisp-query (bonus_tty (name count) nil tty tty :single t)
+     (make-instance 'btty :tty tty :name name :hits (ensure-integer count))))
+
+(defun find-btty-all ()
+ (u::collect-umlisp-query (bonus_tty (tty name count) nil nil nil :order (tty asc))
+  (make-instance 'btty :tty tty :name name :hits (ensure-integer count))))
+
+(defun find-brel-rel (rel)
+  (u::collect-umlisp-query (bonus_rel (sab sl rel rela count) nil rel rel)
+     (make-instance 'brel :sab sab :sl sl :rel rel :rela rela
+		    :hits (ensure-integer count))))
+