;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; Name: sql-classes.lisp
-;;;; Purpose: Routines for reading UMLS objects from SQL database
-;;;; Author: Kevin M. Rosenberg
-;;;; Date Started: Apr 2000
+;;;; Name: sql-classes.lisp
+;;;; Purpose: Routines for reading UMLS objects from SQL database
+;;;; Author: Kevin M. Rosenberg
+;;;; Created: Apr 2000
;;;;
-;;;; $Id: sql-classes.lisp,v 1.88 2003/07/21 00:53:27 kevin Exp $
+;;;; $Id$
;;;;
;;;; This file, part of UMLisp, is
;;;; Copyright (c) 2000-2003 by Kevin M. Rosenberg, M.D.
,@(when %%where
`((typecase ,where-value
(fixnum
- (prefixed-fixnum-string ,where-value #\= 10))
+ (concatenate 'string "='" (prefixed-fixnum-string ,where-value #\0 10) "'"))
(number
- (concatenate 'string "=" (write-to-string ,where-value)))
+ (concatenate 'string "='" (write-to-string ,where-value) "'"))
(null
" is null")
(t
(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
:pfstr kpfstr
:lrl (ensure-integer kcuilrl))))
+(defun find-cui-ucon-all (&key (srl *current-srl*))
+ "Return list of CUIs for all ucons"
+ (collect-umlisp-query (mrcon (cui) srl nil nil :order (cui asc)
+ :distinct t)
+ cui))
+
(defun map-ucon-all (fn &key (srl *current-srl*))
"Map a function over all ucon's"
(with-sql-connection (db)
:cui2 (ensure-integer cui2) :rela rela :sab sab :sl sl
:mg mg :pfstr2 kpfstr2)))
+(defun find-cui2-urel-cui (cui &key (srl *current-srl*))
+ "Return a list of urel for cui"
+ (ensure-cui-integer cui)
+ (collect-umlisp-query (mrrel (cui2) srl cui1
+ cui :lrl "KSRL")
+ cui2))
+
(defun find-urel-cui2 (cui2 &key (srl *current-srl*))
"Return a list of urel for cui2"
(ensure-cui-integer cui2)
(collect-umlisp-query (mrcoc (cui2 soc cot cof coa kpfstr2) srl cui1
cui :lrl klrl :order (cof asc))
(setq cui2 (ensure-integer cui2))
- (when (zerop cui2) (setq cui2 nil))
+ (when (eql 0 cui2) (setq cui2 nil))
(make-instance 'ucoc :cui1 cui :cui2 (ensure-integer cui2)
:soc soc :cot cot :cof (ensure-integer cof) :coa coa
:pfstr2 kpfstr2)))
(ensure-sui-integer sui)
(let ((ls "select CODE,ATN,SAB,ATV from MRSAT where "))
(cond
- (sui (string-append ls "KCUISUI="
- (integer-string (make-cuisui cui sui) 14)))
- (lui (string-append ls "KCUILUI="
+ (sui (string-append ls "KCUISUI='"
+ (integer-string (make-cuisui cui sui) 14)
+ "'"))
+ (lui (string-append ls "KCUILUI='"
(integer-string (make-cuilui cui lui) 14)
- " and sui=0"))
- (t (string-append ls "cui=" (prefixed-fixnum-string cui nil 7)
- " and lui=0 and sui=0")))
+ "' and sui='0'"))
+ (t (string-append ls "cui='" (prefixed-fixnum-string cui nil 7)
+ "' and lui='0' and sui='0'")))
(when srl
(string-append ls " and KSRL<=" (prefixed-fixnum-string srl nil 3)))
(loop for tuple in (mutex-sql-query ls) collect
(defun find-usab-all ()
"Find usab for a key"
- (collect-umlisp-query (mrsab (vcui rcui vsab rsab son sf sver mstart mend imeta
+ (collect-umlisp-query (mrsab (vcui rcui vsab rsab son sf sver vstart vend imeta
rmeta slc scc srl tfr cfr cxty ttyl atnl lat
cenc curver sabin) nil nil nil)
(make-instance 'usab :vcui (ensure-integer vcui)
:rcui (ensure-integer rcui) :vsab vsab :rsab rsab :son son
- :sf sf :sver sver :mstart mstart :mend mend :imeta imeta
+ :sf sf :sver sver :vstart vstart :vend vend :imeta imeta
:rmeta rmeta :slc slc :scc scc :srl (ensure-integer srl)
:tfr (ensure-integer tfr) :cfr (ensure-integer cfr)
:cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc
(defun find-usab-by-key (key-name key)
"Find usab for a key"
- (collect-umlisp-query-eval ('mrsab '(vcui rcui vsab rsab son sf sver mstart
- mend imeta rmeta slc scc srl tfr cfr cxty
+ (collect-umlisp-query-eval ('mrsab '(vcui rcui vsab rsab son sf sver vstart
+ vend imeta rmeta slc scc srl tfr cfr cxty
ttyl atnl lat cenc curver sabin)
nil key-name key :single t)
(make-instance 'usab :vcui (ensure-integer vcui)
:rcui (ensure-integer rcui) :vsab vsab :rsab rsab :son son
- :sf sf :sver sver :mstart mstart :mend mend :imeta imeta
+ :sf sf :sver sver :vstart vstart :vend vend :imeta imeta
:rmeta rmeta :slc slc :scc scc :srl (ensure-integer srl)
:tfr (ensure-integer tfr) :cfr (ensure-integer cfr)
:cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc
:lrl 'klrl :order '(cui asc))
(find-ucon-cui cui :srl srl)))
+(defun find-cui-normalized-word (word &key (srl *current-srl*) (like nil))
+ "Return list of cui that match word, optionally use SQL's LIKE syntax"
+ (collect-umlisp-query-eval ('mrxnw_eng '(cui) srl 'nwd word :like like :distinct t
+ :lrl 'klrl :order '(cui asc))
+ cui))
+
+(defun find-lui-normalized-word (word &key (srl *current-srl*) (like nil))
+ "Return list of cui that match word, optionally use SQL's LIKE syntax"
+ (collect-umlisp-query-eval ('mrxnw_eng '(lui) srl 'nwd word :like like :distinct t
+ :lrl 'klrl :order '(cui asc))
+ lui))
+
+(defun find-sui-normalized-word (word &key (srl *current-srl*) (like nil))
+ "Return list of cui that match word, optionally use SQL's LIKE syntax"
+ (collect-umlisp-query-eval ('mrxnw_eng '(sui) srl 'nwd word :like like :distinct t
+ :lrl 'klrl :order '(cui asc))
+ sui))
+
(defun find-ustr-word (word &key (srl *current-srl*))
"Return list of ustrs that match word"
(collect-umlisp-query (mrxw_eng (cui sui) srl wd word :lrl klrl
(make-instance 'ltyp :eui eui :bas bas :sca sca :typ typ)))
(defun find-lwd-wrd (wrd)
- (make-instance 'lwd :wrd
+ (make-instance 'lwd :wrd wrd
:euilist (collect-umlisp-query (lrwd (eui) nil wrd wrd)
- (ensure-integer eui))))
+ (ensure-integer eui))))
;;; Semantic Network SQL access 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)
+ (ignore-errors (sql-execute "drop table 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*))
+ (if 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)))
+ (collect-umlisp-query (ustats (name count srl) nil nil nil
+ :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 ()
+ (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)
+ (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