;;;; 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.
(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)))
;; 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
(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
(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"
;;; 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"
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
(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))))
+
projects / umlisp.git / blobdiff