From 750cc1891b279fb8fa6a9e4e8bd699a0cb874485 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Mon, 21 Jul 2003 09:46:22 +0000 Subject: [PATCH] r5361: *** empty log message *** --- classes.lisp | 71 +++++++++++++++++++++++++++++- create-sql.lisp | 5 ++- package.lisp | 11 ++++- sql-classes.lisp | 109 ++++++++++++++++++++++++++++++++++++++++++++--- 4 files changed, 185 insertions(+), 11 deletions(-) diff --git a/classes.lisp b/classes.lisp index 9b5a71f..ac03ad9 100644 --- a/classes.lisp +++ b/classes.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: classes.lisp,v 1.42 2003/06/29 16:21:09 kevin Exp $ +;;;; $Id: classes.lisp,v 1.43 2003/07/21 09:46:22 kevin Exp $ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2003 by Kevin M. Rosenberg, M.D. @@ -429,3 +429,72 @@ "Fully Inherited Set of Relations (strings)") (:default-print-slots sty rl sty2)) + +;;; ************************** +;;; Local Classes +;;; ************************** + +(defclass ustats (umlsclass) + ((name :value-type string :initarg :name :reader name) + (hits :value-type integer :initarg :hits :reader hits + :user-name "count" + :print-formatter fmt-comma-integer) + (srl :value-type fixnum :initarg :srl :reader srl)) + (:metaclass hyperobject-class) + (:default-initargs :name nil :hits nil :srl nil) + (:user-name "UMLS Statistic") + (:default-print-slots name hits srl) + (:documentation "Custom Table: UMLS Database statistics.")) + + +(defclass bsab (umlsclass) + ((sab :value-type string :initarg :sab :reader sab + :hyperlink find-ustr-sab + :hyperlink-parameters (("subobjects" . "no"))) + (name :value-type string :initarg :name :reader name) + (hits :value-type fixnum :initarg :hits :reader hits + :user-name "count" + :print-formatter fmt-comma-integer)) + (:metaclass hyperobject-class) + (:default-initargs :sab nil :name nil :hits nil) + (:user-name "Source of Abbreviation") + (:default-print-slots sab name hits) + (:documentation "Bonus SAB file")) + +(defclass btty (umlsclass) + ((tty :value-type string :initarg :tty :reader tty) + (name :value-type string :initarg :name :reader name) + (hits :value-type fixnum :initarg :hits :reader hits + :user-name "count" + :print-formatter fmt-comma-integer)) + (:metaclass hyperobject-class) + (:default-initargs :tty nil :name nil :hits nil) + (:user-name "Bonus TTY") + (:default-print-slots tty name hits) + (:documentation "Bonus TTY file")) + +(defclass brel (umlsclass) + ((sab :value-type string :initarg :sab :reader sab) + (sl :value-type string :initarg :sl :reader sl) + (rel :value-type string :initarg :rel :reader rel) + (rela :value-type string :initarg :rela :reader rela) + (hits :value-type fixnum :initarg :hits :reader hits + :user-name "count" + :print-formatter fmt-comma-integer)) + (:metaclass hyperobject-class) + (:default-initargs :sab nil :sl nil :rel nil :rela nil :hits nil) + (:user-name "Bonus REL") + (:default-print-slots sab sl rel rela hits) + (:documentation "Bonus REL file")) + +(defclass batn (umlsclass) + ((sab :value-type string :initarg :sab :reader sab) + (atn :value-type string :initarg :atn :reader atn) + (hits :value-type fixnum :initarg :hits :reader hits + :user-name "count" + :print-formatter fmt-comma-intger)) + (:metaclass hyperobject-class) + (:default-initargs :sab nil :atn nil) + (:user-name "Bonus ATN") + (:default-print-slots sab atn hits) + (:documentation "Bonus ATN file")) diff --git a/create-sql.lisp b/create-sql.lisp index 763418d..3481311 100644 --- a/create-sql.lisp +++ b/create-sql.lisp @@ -7,7 +7,7 @@ ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: create-sql.lisp,v 1.6 2003/06/10 22:30:16 kevin Exp $ +;;;; $Id: create-sql.lisp,v 1.7 2003/07/21 09:46:22 kevin Exp $ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2003 by Kevin M. Rosenberg, M.D. @@ -154,7 +154,8 @@ conn))) (defun sql-create-special-tables (conn) - (make-usrl conn)) + (make-usrl conn) + (make-ustats)) (defun create-umls-db-by-insert () "SQL Databases: initializes entire database via SQL insert commands" diff --git a/package.lisp b/package.lisp index ded476c..259c5f4 100644 --- a/package.lisp +++ b/package.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: package.lisp,v 1.28 2003/07/21 08:41:44 kevin Exp $ +;;;; $Id: package.lisp,v 1.29 2003/07/21 09:46:22 kevin Exp $ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2003 by Kevin M. Rosenberg, M.D. @@ -157,8 +157,15 @@ #:display-con #:display-term #:display-str + #:find-ustats-all + #:find-ustats-srl + #:find-bsab-sab + #:find-bsab-all + #:find-btty-all + #:find-btty-tty + #:find-brel-rel - ;; composite.cl + ;; composite.lisp #:tui-finding #:tui-sign-or-symptom #:tui-disease-or-syndrome diff --git a/sql-classes.lisp b/sql-classes.lisp index 3af923d..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.88 2003/07/21 00:53:27 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 @@ -748,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)))) + -- 2.34.1