From e70c7b119ecfffb895d5536d0edb1fd373633038 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Thu, 14 Sep 2006 00:50:14 +0000 Subject: [PATCH] r11146: add source finding, add limit and filters to query --- classes.lisp | 10 ++- package.lisp | 6 +- sql-classes.lisp | 174 ++++++++++++++++++++++++++++------------------- 3 files changed, 114 insertions(+), 76 deletions(-) diff --git a/classes.lisp b/classes.lisp index 3d8c2ea..0a926b6 100644 --- a/classes.lisp +++ b/classes.lisp @@ -147,8 +147,10 @@ (:user-name "String") (:default-print-slots sui stt lrl str suppress)) + (defclass uso (umlsclass) - ((aui :value-type fixnum :initarg :aui :reader aui :print-formatter fmt-aui) + ((aui :value-type fixnum :initarg :aui :reader aui :print-formatter fmt-aui + :hyperlink find-ucon-aui) (cui :value-type fixnum :initarg :cui :reader cui :print-formatter fmt-cui :hyperlink find-ucon-cui) (sui :value-type fixnum :initarg :sui :reader sui :print-formatter fmt-sui @@ -157,8 +159,10 @@ (sdui :value-type string :initarg :sdui :reader sdui) (scui :value-type string :initarg :scui :reader scui) (tty :value-type string :initarg :tty :reader tty :hyperlink find-btty-tty) - (sab :value-type string :initarg :sab :reader sab :hyperlink find-usab-rsab) (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) + (str :value-type cdata :initarg :str :reader str) (srl :value-type fixnum :initarg :srl :reader srl)) (:metaclass hyperobject-class) (:user-name "Source") @@ -239,13 +243,13 @@ (:user-name "Co-occuring Concept") (:default-print-slots cot cof coa cui2 aui2 sab pfstr2)) - (defclass ucon (umlsclass) ((cui :value-type fixnum :initarg :cui :reader cui :print-formatter fmt-cui :hyperlink find-ucon-cui) (lrl :value-type fixnum :initarg :lrl :reader lrl) (pfstr :value-type cdata :initarg :pfstr :reader pfstr) (s#def :reader s#def :subobject (find-udef-cui cui)) + (s#so :reader s#so :subobject (find-uso-cui cui)) (s#sty :reader s#sty :subobject (find-usty-cui cui)) (s#lo :reader s#lo :subobject (find-ulo-cui cui)) (s#term :reader s#term :subobject (find-uterm-cui cui)) diff --git a/package.lisp b/package.lisp index 5b96144..d7e5a86 100644 --- a/package.lisp +++ b/package.lisp @@ -32,9 +32,9 @@ #:lexterm #:labr #:lagr #:lcmp #:lmod #:lnom #:lprn #:lprp #:lspl #:ltrm #:ltyp #:lwd #:sdef #:sstr #:sstre1 #:sstre2 #:sty #:tui #:def #:sab #:srl #:tty #:rank #:supres #:atn #:atv #:vcui - #:rcui #:vsab + #:rcui #:vsab #:code #:saui :scui :sdui #:rl #:sty2 #:ui #:ui2 #:ui3 #:eui #:bas #:eui2 #:bas2 - #:cui #:lui #:sui #:wd #:lat #:nstr :cuilist + #:cui #:aui #:lui #:sui #:wd #:lat #:nstr :cuilist #:rsab #:lat #:s#def #:s#sty #:s#term #:s#str #:s#lo #:s#sat #:s#rel #:s#coc #:s#so #:s#cxt @@ -108,6 +108,8 @@ #:find-ustr-all #:find-string-sui #:find-uso-cuisui + #:find-uso-cui + #:find-uso-aui #:find-ucxt-cuisui #:find-usat-ui #:find-usab-all diff --git a/sql-classes.lisp b/sql-classes.lisp index 2831def..9d6852b 100644 --- a/sql-classes.lisp +++ b/sql-classes.lisp @@ -26,37 +26,54 @@ (setq *current-srl* srl)) (defmacro query-string (table fields &optional srl where-name where-value - &key (lrl "KCUILRL") single distinct order like) - (let* ((%%fields (format nil "select ~A~{~:@(~A~)~^,~} from ~:@(~A~)" - (if distinct "distinct " "") fields table)) - (%%order (if order (format nil " order by ~{~:@(~A~) ~(~A~)~^,~}" + &key (lrl "KCUILRL") single distinct order like limit + filter) + (let* ((%%fields (format nil "SELECT ~A~{~:@(~A~)~^,~} FROM ~:@(~A~)" + (if distinct "DISTINCT " "") fields table)) + (%%order (if order (format nil " ORDER BY ~{~:@(~A~) ~(~A~)~^,~}" order) "")) - (%%lrl (format nil " and ~:@(~A~)<=" lrl)) + (%%lrl (format nil " AND ~:@(~A~)<=" lrl)) (%%where (when where-name (format nil " where ~:@(~A~)~A" where-name - (if like " like " ""))))) - `(concatenate - 'string - ,%%fields - ,@(when %%where (list %%where)) - ,@(when %%where - `((typecase ,where-value - #+ignore - (fixnum - (concatenate 'string "='" (prefixed-fixnum-string ,where-value #\0 10) "'")) - (number - (concatenate 'string "='" (write-to-string ,where-value) "'")) - (null - " is null") - (t - (format nil ,(if like "'%~A%'" "='~A'") ,where-value))))) - (if ,srl (concatenate 'string ,%%lrl (write-to-string ,srl)) "") - ,@(when %%order (list %%order)) - ,@(when single (list " limit 1"))))) + (if like " like " "")))) + (%%limit (gensym "LIMIT-")) + (%%filter (gensym "FILTER-"))) + `(let ((%%limit ,limit) + (%%filter ,filter)) + (concatenate + 'string + ,%%fields + ,@(when %%where (list %%where)) + ,@(when %%where + `((typecase ,where-value + #+ignore + (fixnum + (concatenate 'string "='" (prefixed-fixnum-string ,where-value #\0 10) "'")) + (number + (concatenate 'string "='" (write-to-string ,where-value) "'")) + (null + " is null") + (t + (format nil ,(if like "'%~A%'" "='~A'") ,where-value))))) + (if ##filter (concatenate 'string " AND " ##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 + "")) + ""))))) (defun query-string-eval (table fields &optional srl where-name where-value - &key (lrl "KCUILRL") single distinct order like) + &key (lrl "KCUILRL") single distinct order like limit filter) + (when single (setq limit 1)) (concatenate 'string (format nil "select ~A~{~:@(~A~)~^,~} from ~:@(~A~)" @@ -71,64 +88,72 @@ (if like " like '%~A%""='~A'"))) where-value) "") + (if filter (concatenate 'string " AND " filter) nil) (if srl (format nil " and ~:@(~A~)<=~D" lrl srl) "") (if order (format nil " order by ~{~:@(~A~) ~(~A~)~^,~}" order) "") - (if single " limit 1" ""))) + (if limit (format nil " limit ~D" limit) ""))) (defmacro umlisp-query (table fields srl where-name where-value &key (lrl "KCUILRL") single distinct order like - (query-cmd 'mutex-sql-query)) + limit filter (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" `(,query-cmd (query-string ,table ,fields ,srl ,where-name ,where-value - :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like))) + :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like + :filter filter :limit ,limit))) (defmacro umlisp-query-eval (table fields srl where-name where-value - &key (lrl "KCUILRL") single distinct order like) + &key (lrl "KCUILRL") single distinct order like + filter limit) "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-string-eval ,table ,fields ,srl ,where-name ,where-value - :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like))) + :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like + :filter filter :limit ,limit))) ;; 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 (query-cmd 'mutex-sql-query)) + order like (query-cmd 'mutex-sql-query) + filter limit) &body body) (let ((value (gensym)) (r (gensym))) (if single - `(let* ((,value ,where-value) - (tuple (car (umlisp-query ,table ,fields ,srl ,where-name ,value - :lrl ,lrl :single ,single - :distinct ,distinct :order ,order - :like ,like - :query-cmd ,query-cmd)))) - ,@(unless where-name `((declare (ignore ,value)))) - (when tuple - (destructuring-bind ,fields tuple - ,@body))) + (if (and limit (> limit 1)) + (error "Can't set limit along with single.") + `(let* ((,value ,where-value) + (tuple (car (umlisp-query ,table ,fields ,srl ,where-name ,value + :lrl ,lrl :single ,single + :distinct ,distinct :order ,order + :like ,like :filter ,filter + :query-cmd ,query-cmd)))) + ,@(unless where-name `((declare (ignore ,value)))) + (when tuple + (destructuring-bind ,fields tuple + ,@body)))) `(let ((,value ,where-value)) ,@(unless where-name `((declare (ignore ,value)))) (let ((,r '())) (dolist (tuple (umlisp-query ,table ,fields ,srl ,where-name ,value :lrl ,lrl :single ,single :distinct ,distinct - :order ,order :like ,like)) + :order ,order :filter ,filter :like ,like + :limit ,limit)) (push (destructuring-bind ,fields tuple ,@body) ,r)) (nreverse ,r)) #+ignore (loop for tuple in (umlisp-query ,table ,fields ,srl ,where-name ,value :lrl ,lrl :single ,single :distinct ,distinct - :order ,order :like ,like) + :order ,order :like ,like :filter ,filter :limit ,limit) collect (destructuring-bind ,fields tuple ,@body)))))) (defmacro collect-umlisp-query-eval ((table fields srl where-name where-value &key (lrl "KCUILRL") distinct single - order like) + order like filter limit) &body body) (let ((value (gensym)) (r (gensym)) @@ -138,7 +163,8 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (tuple (car (umlisp-query-eval ,table ,fields ,srl ,where-name ,value :lrl ,lrl :single ,single :distinct ,distinct :order ,order - :like ,like)))) + :like ,like :filter ,filter + :limit ,limit)))) (when tuple (destructuring-bind ,eval-fields tuple ,@body))) @@ -146,14 +172,16 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (,r '())) (dolist (tuple (umlisp-query-eval ,table ,fields ,srl ,where-name ,value :lrl ,lrl :single ,single :distinct ,distinct - :order ,order :like ,like)) + :order ,order :like ,like + :filter ,filter :limit ,limit)) (push (destructuring-bind ,eval-fields tuple ,@body) ,r)) (nreverse ,r) #+ignore (loop for tuple in (umlisp-query-eval ,table ,fields ,srl ,where-name ,value :lrl ,lrl :single ,single :distinct ,distinct - :order ,order :like ,like) + :order ,order :like ,like :filter ,filter + :limit ,limit) collect (destructuring-bind ,eval-fields tuple ,@body)))))) ;;; @@ -214,31 +242,24 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" "Find preferred string for a cui" (ensure-cui-integer cui) (or - (caar (mutex-sql-query - (format nil "SELECT DISTINCT str FROM MRCONSO WHERE CUI=~D AND KPFENG=1~A LIMIT 1" - cui (if srl (format nil " AND SRL<=~D" srl) "")))) - (caar (mutex-sql-query - (format nil "SELECT DISTINCT str FROM MRCONSO WHERE CUI=~D~A LIMIT 1" - cui (if srl (format nil " AND SRL<=~D" srl) "")))))) + (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)))) (defun find-ucon-lui (lui &key (srl *current-srl*)) "Find list of ucon for lui" (ensure-lui-integer lui) - (collect-umlisp-query (mrconso (cui kcuilrl) srl lui lui - :distinct t) - (make-instance 'ucon :cui (ensure-integer cui) :pfstr (find-pfstr-cui cui) - :lrl (ensure-integer kcuilrl))) (unless lui (return-from find-ucon-lui nil)) - - (let ((tuple (car (mutex-sql-query "SELECT cui,kcuilrl,str FROM MRCONSO WHERE LUI=~D AND KPFENG=1~A ORDER BY kcuilrl ASC LIMIT 1" - lui (if srl (format nil " AND SRL<=~D" srl) ""))))) - (unless tuple - (setq tuple (car (mutex-sql-query "SELECT cui,kcuilrl,str FROM MRCONSO WHERE LUI=~D~A ORDER BY kcuilrl ASC LIMIT 1" - lui (if srl (format nil " AND SRL<=~D" srl) ""))))) - (unless tuple - (return-from find-ucon-lui nil)) - (make-instance 'ucon :cui (first tuple) :pfstr (third tuple) - :lrl (ensure-integer (third tuple))))) + (or + (collect-umlisp-query (mrconso (cui kcuilrl str) srl lui lui + :filter " KPFENG=1" :single t) + (make-instance 'ucon :cui (ensure-integer cui) + :pfstr str :lrl (ensure-integer kcuilrl))) + (collect-umlisp-query (mrconso (cui kcuilrl str) srl lui lui + :single t) + (make-instance 'ucon :cui (ensure-integer cui) + :pfstr str :lrl (ensure-integer kcuilrl))))) (defun find-ucon-sui (sui &key (srl *current-srl*)) "Find list of ucon for sui" @@ -511,17 +532,28 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (defun find-uso-cuisui (cui sui &key (srl *current-srl*)) (ensure-sui-integer sui) (ensure-cui-integer cui) - (collect-umlisp-query (mrconso (aui sab code srl tty saui sdui scui) srl kcuisui + (collect-umlisp-query (mrconso (aui sab code srl tty saui sdui scui lat str) srl kcuisui (make-cuisui cui sui) :lrl srl) (make-instance 'uso :aui aui :sab sab :code code :srl srl :tty tty - :cui cui :sui sui :saui saui :sdui sdui :scui scui))) + :cui cui :sui sui :saui saui :sdui sdui :scui scui + :lat lat :str str))) + +(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) + 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 + :cui cui :sui sui :saui saui :sdui sdui :scui scui + :lat lat :str str))) (defun find-uso-aui (aui &key (srl *current-srl*)) (ensure-sui-integer aui) - (collect-umlisp-query (mrconso (sab cui sui code srl tty saui sdui scui) srl aui + (collect-umlisp-query (mrconso (sab cui sui code srl tty saui sdui scui lat str) srl aui aui :lrl srl :single t) (make-instance 'uso :aui aui :cui cui :sab sab :code code :srl srl :tty tty - :sui sui :saui saui :sdui sdui :scui scui))) + :sui sui :saui saui :sdui sdui :scui scui + :lat lat :str str))) (defun find-ucxt-cuisui (cui sui &key (srl *current-srl*)) (ensure-cui-integer cui) -- 2.34.1