r11148: fix limit / filter, improve udoc support

diff --git a/class-support.lisp b/class-support.lisp
index e7fe96025c47aa25126d121162bf286b68d4ea2c..dd969038bc87ee7e65396631be22e207d85c1d2c 100644 (file)
--- a/class-support.lisp
+++ b/class-support.lisp
@@ -368,7 +368,14 @@
         (sort anc-this-cxn (lambda (a b) (< (rank a) (rank b))))
         anc-lists)))))
 
-
+(defun uso-unique-codes (usos)
+  (let ((sab-codes (make-hash-table :test 'equal)))
+    (dolist (uso usos)
+      (setf (gethash (sab uso) sab-codes) (code uso)))
+    (loop for key being the hash-key in sab-codes
+        collect (list key (gethash key sab-codes)))))
+
+                                          
 #+scl
 (dolist (c '(urank udef usat uso ucxt ustr ulo uterm usty urel ucoc uatx ucon uxw uxnw uxns lexterm labr lagr lcmp lmod lnom lprn lprp lspl ltrm ltyp lwd sdef sstr sstre1 sstre2 usrl))
     (let ((cl (find-class c)))

diff --git a/classes.lisp b/classes.lisp
index 0a926b617f1fcc42c23c6889bda2249f17a9f97f..aed5b64b2ccc98a3365f3ae622e36b21c399ac61 100644 (file)
--- a/classes.lisp
+++ b/classes.lisp
@@ -161,7 +161,7 @@
    (tty :value-type string :initarg :tty :reader tty :hyperlink find-btty-tty)
    (code :value-type string :initarg :code :reader code)
    (sab :value-type string :initarg :sab :reader sab :hyperlink find-usab-rsab)
-   (lat :value-type string :initarg lat :reader lat)
+   (lat :value-type string :initarg :lat :reader lat)
    (str :value-type cdata :initarg :str :reader str)
    (srl :value-type fixnum :initarg :srl :reader srl))
   (:metaclass hyperobject-class)
@@ -260,15 +260,6 @@
   (:user-name "Concept")
   (:default-print-slots cui lrl pfstr))
 
-(defclass udoc (umlsclass)
-  ((key :value-type string :initarg :key :reader key)
-   (value :value-type cdata :initarg :value :reader value)
-   (type :value-type cdata :initarg :type :reader etype)
-   (expl :value-type cdata :initarg :expl :reader expl))
-  (:metaclass hyperobject-class)
-  (:user-name "Abbreviation Documentation")
-  (:default-print-slots key value type expl))
-
 (defclass umap (umlsclass)
   ((mapsetcui :value-type fixnum :initarg :mapsetcui :reader mapsetcui)
    (mapsetsab :value-type string :initarg :mapsetsab :reader mapsetsab)
@@ -350,6 +341,15 @@
   (:user-name "XNS Index" "XNS Indices")
   (:default-print-slots lat nstr cuilist))
 
+(defclass udoc (umlsclass)
+  ((dockey :value-type string :initarg :dockey :reader dockey)
+   (expl :value-type cdata :initarg :expl :reader expl)
+   (dtype :value-type cdata :initarg :dtype :reader dtype)
+   (dvalue :value-type cdata :initarg :dvalue :reader dvalue))
+  (:metaclass hyperobject-class)
+  (:user-name "Documentation record")
+  (:default-print-slots dockey expl dtype dvalue))
+
 
 ;;; LEX objects
 

diff --git a/package.lisp b/package.lisp
index d7e5a8677bdf7ecf19ff3dbb7798346fabd96294..f426ca445ff1c2d75b8ac432bc2cbf53cf094d6b 100644 (file)
--- a/package.lisp
+++ b/package.lisp
@@ -52,6 +52,7 @@
    #:ucon-ancestors #:ucon-parents
    #:mesh-number #:cxt-ancestors #:ucon-ustrs
    #:lat-abbr-info #:stt-abbr-info
+   #:uso-unique-codes
    
    ;; From sql.lisp
    #:*umls-sql-db*

diff --git a/sql-classes.lisp b/sql-classes.lisp
index 9d6852b8cca7bcebda125394e74023f02b7b6631..c91ee8a11b6144b77d769d6af515606d3b282197 100644 (file)
--- a/sql-classes.lisp
+++ b/sql-classes.lisp
@@ -37,10 +37,12 @@
         (%%where (when where-name
                    (format nil " where ~:@(~A~)~A" where-name
                          (if like " like " ""))))
-         (%%limit (gensym "LIMIT-"))
-         (%%filter (gensym "FILTER-")))
-    `(let ((%%limit ,limit)
-           (%%filter ,filter))
+         (%filter (gensym "FILTER-"))
+         (%single (gensym "SINGLE-"))
+         (%limit (gensym "LIMIT-")))
+    `(let ((,%limit ,limit)
+           (,%single ,single)
+           (,%filter ,filter))
        (concatenate
         'string
         ,%%fields
@@ -56,20 +58,20 @@
                  " is null")
                 (t
                  (format nil ,(if like "'%~A%'" "='~A'") ,where-value)))))
-        (if ##filter (concatenate 'string " AND " ##filter) "")
+        (if ,%filter (concatenate 'string
+                                  ,(if %%where " AND " " WHERE ")
+                                  ,%filter) "")
         (if ,srl (concatenate 'string ,%%lrl (write-to-string ,srl)) "")
         ,@(when %%order (list %%order))
-        (if (or ,single ##limit)
-            (cond
-             ((and ,single (> ##limit 1))
-              (error "Can't set single and limit > 1."))
-             (,single
-              " LIMIT 1")
-             (##limit
-              (format nil " LIMIT ~D" ##limit))
-             (t
-              ""))
-          "")))))
+        (cond
+         ((and ,%single ,%limit)
+          (error "Can't set single and limit"))
+         (,%single
+          " LIMIT 1")
+         (,%limit
+          (format nil " LIMIT ~D" ,%limit))
+         (t
+          ""))))))
 
 (defun query-string-eval (table fields &optional srl where-name where-value
                          &key (lrl "KCUILRL") single distinct order like limit filter)
@@ -102,7 +104,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
   `(,query-cmd
     (query-string ,table ,fields ,srl ,where-name ,where-value
      :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like
-     :filter filter :limit ,limit)))
+     :filter ,filter :limit ,limit)))
 
 (defmacro umlisp-query-eval (table fields srl where-name where-value
                     &key (lrl "KCUILRL") single distinct order like 
@@ -112,7 +114,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
   `(mutex-sql-query
     (query-string-eval ,table ,fields ,srl ,where-name ,where-value
      :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like
-     :filter filter :limit ,limit)))
+     :filter ,filter :limit ,limit)))
 
 ;; only WHERE-VALUE and SRL are evaluated
 (defmacro collect-umlisp-query ((table fields srl where-name where-value
@@ -242,10 +244,12 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
   "Find preferred string for a cui"
   (ensure-cui-integer cui)
   (or
-   (collect-umlisp-query (mrconso (kpfstr) srl cui cui :distinct t 
-                                  :filter " KPFENG=1" :single t))
-   (collect-umlisp-query (mrconso (kpfstr) srl cui cui :distinct t 
-                                  :single t))))
+   (collect-umlisp-query (mrconso (str) srl cui cui :distinct t 
+                                  :filter " KPFENG=1" :single t)
+      str)
+   (collect-umlisp-query (mrconso (str) srl cui cui :distinct t 
+                                  :single t)
+      str)))
 
 (defun find-ucon-lui (lui &key (srl *current-srl*))
   "Find list of ucon for lui"
@@ -344,24 +348,21 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
 (defun find-udoc-key (key)
   "Return list of abbreviation documentation for a key"
   (collect-umlisp-query (mrdoc (value type expl) nil dockey key)
-    (make-instance 'udoc :key key :value value :type type :expl expl)))
+    (make-instance 'udoc :dockey key :dvalue value :dtype type :expl expl)))
 
 (defun find-udoc-value (value)
   "Return abbreviation documentation"
   (collect-umlisp-query (mrdoc (dockey type expl) nil value value)
-    (make-instance 'udoc :key dockey :value value :type type :expl expl)))
+    (make-instance 'udoc :dockey dockey :dvalue value :dtype type :expl expl)))
 
-(defun find-udoc-key-value (key value)
-  (let ((tuple (car (mutex-sql-query
-                    (format nil "SELECT TYPE,EXPL FROM MRDOC WHERE DOCKEY='~A' AND VALUE='~A'"
-                            key value)))))
-    (when tuple
-      (make-instance 'udoc :key key :value value :type (first tuple) :expl (second tuple)))))
+(defun find-udoc-key-value (dockey value)
+  (collect-umlisp-query (mrdoc (type expl) nil dockey dockey :filter (format nil "VALUE='~A'" value))
+      (make-instance 'udoc :dockey dockey :dvalue value :dtype type :expl expl)))
 
 (defun find-udoc-all ()
   "Return all abbreviation documentation"
   (collect-umlisp-query (mrdoc (dockey value type expl) nil nil nil)
-    (make-instance 'udoc :key dockey :value value :type type :expl expl)))
+    (make-instance 'udoc :dockey dockey :dvalue value :dtype type :expl expl)))
 
 (defun find-usty-cui (cui &key (srl *current-srl*))
   "Return a list of usty for cui"
@@ -540,7 +541,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
 
 (defun find-uso-cui (cui &key (srl *current-srl*) (english-only nil) limit)
   (ensure-cui-integer cui)
-  (collect-umlisp-query (mrconso (aui sab code srl tty saui sdui scui lat str) 
+  (collect-umlisp-query (mrconso (aui sab code srl tty saui sdui scui lat str sui) 
                                  srl cui cui :lrl srl :limit limit
                                  :filter (when english-only "LAT='ENG'"))
      (make-instance 'uso :aui aui :sab sab :code code :srl srl :tty tty
@@ -620,7 +621,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
     (find-usty-tui tui)))
 
 (defun find-usab-all ()
-  "Find usab for a key"
+  "Return all usab objects"
   (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 ssn scit) nil nil nil)

diff --git a/umlisp.asd b/umlisp.asd
index bc97895af25f5152d42fd18066799a1c63848518..44aa906dffbc12ad96fe5e3370f4aafe496aa289 100644 (file)
--- a/umlisp.asd
+++ b/umlisp.asd
@@ -38,7 +38,7 @@
    (:file "classes" :depends-on ("sql-classes"))
    (:file "class-support" :depends-on ("classes"))
    (:file "composite" :depends-on ("sql-classes")))
-  :depends-on (clsql clsql-postgresql-socket kmrcl hyperobject))
+  :depends-on (clsql clsql-mysql kmrcl hyperobject))
 
 (defmethod perform ((o test-op) (c (eql (find-system 'umlisp))))
   (operate 'load-op 'umlisp-tests)