From c88fbfe8bd947b12c89f32effaf328699ba067ab Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Thu, 14 Sep 2006 08:37:30 +0000 Subject: [PATCH] r11148: fix limit / filter, improve udoc support --- class-support.lisp | 9 ++++++- classes.lisp | 20 +++++++------- package.lisp | 1 + sql-classes.lisp | 67 +++++++++++++++++++++++----------------------- umlisp.asd | 2 +- 5 files changed, 54 insertions(+), 45 deletions(-) diff --git a/class-support.lisp b/class-support.lisp index e7fe960..dd96903 100644 --- 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 0a926b6..aed5b64 100644 --- 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 d7e5a86..f426ca4 100644 --- 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 9d6852b..c91ee8a 100644 --- 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 bc97895..44aa906 100644 --- 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) -- 2.34.1