r5361: *** empty log message ***

diff --git a/classes.lisp b/classes.lisp
index 9b5a71f97d1dce7651559cccbd6ce1f5977676e5..ac03ad9cb84e3c73799100668a0bbfd6c751b46a 100644 (file)
--- 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 763418d14ef9447cdd8b2ac153c8ffe585370ba0..348131169d7d156c9f64f6745cfee64cb77497e8 100644 (file)
--- 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 ded476c886cc689aaec5d22770b338fd114956e2..259c5f470fa2938a43737f7addeec090af5627ba 100644 (file)
--- 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 3af923d2b1e7c1def2e54282f4cf0c06411275de..52b9ce8873e9f4646b4200b205dbd6460b66262a 100644 (file)
--- 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))))
+