cl-umlisp-2007ac.2/0000755000175000017500000000000010754643523013040 5ustar kevinkevincl-umlisp-2007ac.2/COPYING0000644000175000017500000004311010667175521014073 0ustar kevinkevin GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. cl-umlisp-2007ac.2/Makefile0000644000175000017500000000120310667175521014475 0ustar kevinkevin.PHONY: all clean test test-acl test-sbcl distclean test-file:=`pwd`/run-tests.lisp all: distclean: clean clean: @find . -type f -name "*.fasl*" -or -name "*.ufsl" -or -name "*.x86f" \ -or -name "*.fas" -or -name "*.pfsl" -or -name "*.dfsl" \ -or -name "*~" -or -name ".#*" -or -name "#*#" | xargs rm -f test: test-alisp test-alisp: alisp8 -q -L $(test-file) test-mlisp: mlisp -q -L $(test-file) test-sbcl: sbcl --noinform --disable-debugger --userinit $(test-file) test-cmucl: lisp -init $(test-file) test-lw: lw-console -init $(test-file) test-scl: scl -init $(test-file) test-clisp: clisp -norc -q -i $(test-file) cl-umlisp-2007ac.2/README0000644000175000017500000000070410667175521013722 0ustar kevinkevinThis is UMLisp - An object-oriented, SQL-based interface library to the Unified Medical Language System. This is open-source software governed by the GNU General Public License included with the software in the file COPYING. It is Copyright (C) 2000-2002 by Kevin M. Rosenberg. No documentation is included with this product. Available documentation and support options are on the UMLisp support web site: http://umlisp.med-info.com/support.html cl-umlisp-2007ac.2/class-support.lisp0000644000175000017500000002443410667175521016560 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: classes-support.lisp ;;;; Purpose: Support for UMLisp classes ;;;; Author: Kevin M. Rosenberg ;;;; Created: Apr 2000 ;;;; ;;;; $Id$ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2006 by Kevin M. Rosenberg, M.D. ;;;; ;;;; UMLisp users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU General Public License. ;;;; ************************************************************************* (in-package #:umlisp) ;;; Formatting routines (defgeneric fmt-cui (c)) (defmethod fmt-cui ((c ucon)) (fmt-cui (cui c))) (when *has-fixnum-class* (defmethod fmt-cui ((c fixnum)) (prefixed-fixnum-string c #\C 7))) (defmethod fmt-cui ((c integer)) (prefixed-integer-string c #\C 7)) (defmethod fmt-cui ((c string)) (if (eql (aref c 0) #\C) c (fmt-cui (parse-integer c)))) (defmethod fmt-cui ((c null)) (format nil "nil")) (defgeneric fmt-lui (c)) (defmethod fmt-lui ((l uterm)) (fmt-lui (lui l))) (when *has-fixnum-class* (defmethod fmt-lui ((l fixnum)) (prefixed-fixnum-string l #\L 7))) (defmethod fmt-lui ((l integer)) (prefixed-integer-string l #\L 7)) (defmethod fmt-lui ((l string)) (if (eql (aref l 0) #\L) l (fmt-lui (parse-integer l)))) (defgeneric fmt-sui (s)) (defmethod fmt-sui ((s ustr)) (fmt-sui (sui s))) (when *has-fixnum-class* (defmethod fmt-sui ((s fixnum)) (prefixed-fixnum-string s #\S 7))) (defmethod fmt-sui ((s integer)) (prefixed-integer-string s #\S 7)) (defmethod fmt-sui ((s string)) (if (eql (aref s 0) #\S) s (fmt-sui (parse-integer s)))) (defgeneric fmt-tui (tui)) (when *has-fixnum-class* (defmethod fmt-tui ((tui fixnum)) (prefixed-fixnum-string tui #\T 3))) (defmethod fmt-tui ((tui integer)) (prefixed-integer-string tui #\T 3)) (defmethod fmt-tui ((tui string)) (if (eql (aref tui 0) #\T) tui (fmt-tui (parse-integer tui)))) (defgeneric fmt-aui (aui)) (when *has-fixnum-class* (defmethod fmt-aui ((aui fixnum)) (if (>= aui 10000000) (prefixed-fixnum-string aui #\A 8) (prefixed-fixnum-string aui #\A 7)))) (defmethod fmt-aui ((aui integer)) (if (>= aui 10000000) (prefixed-integer-string aui #\A 8) (prefixed-integer-string aui #\A 7))) (defmethod fmt-aui ((aui string)) (if (eql (aref aui 0) #\A) aui (fmt-aui (parse-integer aui)))) (defgeneric fmt-rui (rui)) (when *has-fixnum-class* (defmethod fmt-rui ((rui fixnum)) (prefixed-fixnum-string rui #\A 8))) (defmethod fmt-rui ((rui integer)) (prefixed-integer-string rui #\A 8)) (defmethod fmt-rui ((rui string)) (if (eql (aref rui 0) #\R) rui (fmt-rui (parse-integer rui)))) (defgeneric fmt-eui (e)) (when *has-fixnum-class* (defmethod fmt-eui ((e fixnum)) (prefixed-fixnum-string e #\E 7))) (defmethod fmt-eui ((e integer)) (prefixed-integer-string e #\E 7)) (defmethod fmt-eui ((e string)) (if (eql (aref e 0) #\E) e (fmt-eui (parse-integer e)))) (defmethod fmt-eui ((e null)) (format nil "nil")) (defun cui-p (ui) "Check if a string is a CUI" (check-ui ui #\C 7)) (defun lui-p (ui) "Check if a string is a LUI" (check-ui ui #\L 7)) (defun sui-p (ui) "Check if a string is a SUI" (check-ui ui #\S 7)) (defun tui-p (ui) (check-ui ui #\T 3)) (defun eui-p (ui) (check-ui ui #\E 7)) (defun check-ui (ui start-char len) (when (and (stringp ui) (= (length ui) (1+ len)) (char-equal start-char (schar ui 0)) (ignore-errors (parse-integer ui :start 1))) t)) ;;; Generic display functions (eval-when (:compile-toplevel :load-toplevel :execute) (defun english-term-p (obj) "Returns two values: T/NIL if term is english and T/NIL if obj is a TERM" (if (eq (hyperobject::class-name (hyperobject::class-of obj)) 'uterm) (values (string-equal (lat obj) "ENG") t) (values nil nil)))) (defun english-term-filter (obj) "Retrns NIL if object is a term and not english" (multiple-value-bind (is-english is-term) (english-term-p obj) (or (not is-term) is-english))) (defun print-umlsclass (obj &key (stream *standard-output*) (vid :compact-text) (file-wrapper nil) (english-only t) (subobjects nil) (refvars nil) (link-printer nil)) (view obj :stream stream :vid vid :subobjects subobjects :file-wrapper file-wrapper :filter (if english-only nil #'english-term-filter) :link-printer link-printer :refvars refvars)) (defmacro define-lookup-display (newfuncname lookup-func) "Defines functions for looking up and displaying objects" `(defun ,newfuncname (keyval &key (stream *standard-output*) (vid :compact-text) (file-wrapper t) (english-only nil) (subobjects nil)) (let ((obj (funcall ,lookup-func keyval))) (print-umlsclass obj :stream stream :vid vid :file-wrapper file-wrapper :english-only english-only :subobjects subobjects) obj))) (define-lookup-display display-con #'find-ucon-cui) (define-lookup-display display-term #'find-uterm-lui) (define-lookup-display display-str #'find-ustr-sui) (defun ucon-has-tui (ucon tui) "Returns T if UCON has a semantic type of TUI." (some #'(lambda (usty) (= tui (tui usty))) (s#sty ucon))) (defgeneric pf-ustr (obj)) (defmethod pf-ustr ((ucon ucon)) "Return the preferred ustr for a ucon" (pf-ustr (find-if (lambda (uterm) (string= "P" (ts uterm))) (s#term ucon)))) (defmethod pf-ustr ((uterm uterm)) "Return the preferred ustr for a uterm" (find-if (lambda (ustr) (string= "PF" (stt ustr))) (s#str uterm))) (defgeneric mesh-number (obj)) (defmethod mesh-number ((con ucon)) (mesh-number (pf-ustr con))) (defmethod mesh-number ((ustr ustr)) (let ((codes (map-and-remove-nils (lambda (sat) (when (and (string-equal "MSH" (sab sat)) (string-equal "MN" (atn sat))) (atv sat))) (s#sat ustr)))) (if (= 1 (length codes)) (car codes) codes))) (defun ucon-ustrs (ucon) "Return lists of strings for a concept" (let (res) (dolist (term (s#term ucon) (nreverse res)) (dolist (str (s#str term)) (push str res))))) (defmethod pfstr ((uterm uterm)) "Return the preferred string for a uterm" (dolist (ustr (s#str uterm)) (when (string= "PF" (stt ustr)) (return-from pfstr (str ustr))))) (defmethod pfstr ((ustr ustr)) "Return the preferred string for a ustr, which is the string itself" (str ustr)) (defun remove-non-english-terms (uterms) (remove-if-not #'english-term-p uterms)) (defun remove-english-terms (uterms) (remove-if #'english-term-p uterms)) (defvar +relationship-abbreviations+ '(("RB" "Broader" "has a broader relationship") ("RN" "Narrower" "has a narrower relationship") ("RO" "Other related" "has relationship other than synonymous, narrower, or broader") ("RL" "Like" "the two concepts are similar or 'alike'. In the current edition of the Metathesaurus, most relationships with this attribute are mappings provided by a source") ("RQ" "Unspecified" "unspecified source asserted relatedness, possibly synonymous") ("SY" "Source Synonymy" "source asserted synonymy") ("PAR" "Parent" "has parent relationship in a Metathesaurus source vocabulary") ("CHD" "Child" "has child relationship in a Metathesaurus source vocabulary") ("SIB" "Sibling" "has sibling relationship in a Metathesaurus source vocabulary") ("AQ" "Allowed" "is an allowed qualifier for a concept in a Metathesaurus source vocabulary") ("QB" "Qualified" "can be qualified by a concept in a Metathesaurus source vocabulary"))) (defvar *rel-info-table* (make-hash-table :size 30 :test 'equal)) (defvar *is-rel-table-init* nil) (unless *is-rel-table-init* (dolist (relinfo +relationship-abbreviations+) (setf (gethash (string-downcase (car relinfo)) *rel-info-table*) (cdr relinfo))) (setq *is-rel-table-init* t)) (defun rel-abbr-info (rel) (nth-value 0 (gethash (string-downcase rel) *rel-info-table*))) (defun filter-urels-by-rel (urels rel) (remove-if-not (lambda (urel) (string-equal rel (rel urel))) urels)) (defvar +language-abbreviations+ '(("BAQ" . "Basque") ("CZE" . "Chech") ("DAN" . "Danish") ("DUT" . "Dutch") ("ENG" . "English") ("FIN" . "Finnish") ("FRE" . "French") ("GER" . "German") ("HEB" . "Hebrew") ("HUN" . "Hungarian") ("ITA" . "Italian") ("JPN" . "Japanese") ("NOR" . "Norwegian") ("POR" . "Portuguese") ("RUS" . "Russian") ("SPA" . "Spanish") ("SWE" . "Swedish"))) (defvar *lat-info-table* (make-hash-table :size 30 :test 'equal)) (defvar *is-lat-table-init* nil) (unless *is-lat-table-init* (dolist (latinfo +language-abbreviations+) (setf (gethash (string-downcase (car latinfo)) *lat-info-table*) (cdr latinfo))) (setq *is-lat-table-init* t)) (defun lat-abbr-info (lat) (aif (nth-value 0 (gethash (string-downcase lat) *lat-info-table*)) it lat)) (defun stt-abbr-info (stt) (when (string-equal "PF" stt) (return-from stt-abbr-info "Preferred")) (when (char-equal #\V (schar stt 0)) (setq stt (subseq stt 1))) (loop for c across stt collect (cond ((char-equal #\C c) "Upper/lower case") ((char-equal #\W c) "Word order") ((char-equal #\S c) "Singular") ((char-equal #\P c) "Plural") ((char-equal #\O c) "Other")))) (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))))) (defun ucon-has-sab (ucon sab) (and (find-if (lambda (uso) (string-equal sab (sab uso))) (s#so ucon)) t)) #+scl (dolist (c '(urank udef usat uso ucxt ustr uterm usty urel ucoc uatx uconso 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))) (clos:finalize-inheritance cl))) cl-umlisp-2007ac.2/classes.lisp0000644000175000017500000006360610667175521015402 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: classes.lisp ;;;; Purpose: Class defintions for UMLisp ;;;; Author: Kevin M. Rosenberg ;;;; Created: Apr 2000 ;;;; ;;;; $Id$ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2006 by Kevin M. Rosenberg, M.D. ;;;; ;;;; UMLisp users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU General Public License. ;;;; ************************************************************************* (in-package #:umlisp) (defclass umlsclass (hyperobject) () (:metaclass hyperobject-class) (:description "Parent class of all UMLS objects. It is based on the HYPEROBJECT-CLASS metaclass that provides object printing functions.")) (defclass usrl (umlsclass) ((sab :value-type string :initarg :sab :reader sab) (srl :value-type fixnum :initarg :srl :reader srl)) (:metaclass hyperobject-class) (:user-name "Source Restriction Level") (:default-print-slots sab srl) (:description "Custom Table: Source Restriction Level")) (defclass urank (umlsclass) ((rank :value-type fixnum :initarg :rank :reader rank) (sab :value-type string :initarg :sab :reader sab) (tty :value-type string :initarg :tty :reader tty) (suppress :value-type string :initarg :suppress :reader suppress)) (:metaclass hyperobject-class) (:user-name "Rank") (:default-print-slots rank sab tty suppres)) (defclass udef (umlsclass) ((def :value-type cdata :initarg :def :reader def) (sab :value-type string :initarg :sab :reader sab :hyperlink find-usab-rsab) (suppress :value-type string :initarg :suppress :reader suppress)) (:metaclass hyperobject-class) (:user-name "Definition") (:default-print-slots sab def)) (defclass usat (umlsclass) ((sab :value-type string :initarg :sab :reader sab :hyperlink find-usab-rsab) (code :value-type string :initarg :code :reader code) (atn :value-type string :initarg :atn :reader atn) (atv :value-type cdata :initarg :atv :reader atv)) (:metaclass hyperobject-class) (:user-name "Simple Attribute") (:default-print-slots sab code atn atv)) (defclass usab (umlsclass) ((vcui :value-type fixnum :initarg :vcui :reader vcui :print-formatter fmt-cui) (rcui :value-type fixnum :initarg :rcui :reader rcui :print-formatter fmt-cui) (vsab :value-type string :initarg :vsab :reader vsab) (rsab :value-type string :initarg :rsab :reader rsab :hyperlink find-ustr-sab :hyperlink-parameters (("subobjects" . "no"))) (son :value-type string :initarg :son :reader son) (sf :value-type string :initarg :sf :reader sf) (sver :value-type string :initarg :sver :reader sver) (vstart :value-type string :initarg :vstart :reader vstart) (vend :value-type string :initarg :vend :reader vend) (imeta :value-type string :initarg :imeta :reader imeta) (rmeta :value-type string :initarg :rmeta :reader rmeta) (slc :value-type cdata :initarg :slc :reader slc) (scc :value-type cdata :initarg :scc :reader scc) (srl :value-type fixnum :initarg :srl :reader srl) (tfr :value-type fixnum :initarg :tfr :reader tfr :print-formatter fmt-comma-integer) (cfr :value-type fixnum :initarg :cfr :reader cfr :print-formatter fmt-comma-integer) (cxty :value-type string :initarg :cxty :reader cxty) (ttyl :value-type string :initarg :ttyl :reader ttyl) (atnl :value-type string :initarg :atnl :reader atnl) (lat :value-type string :initarg :lat :reader lat) (cenc :value-type string :initarg :cenc :reader cenc) (curver :value-type string :initarg :curver :reader curver) (sabin :value-type string :initarg :sabin :reader sabin) (ssn :value-type string :initarg :ssn :reader ssn) (scit :value-type string :initarg :scit :reader scit)) (:metaclass hyperobject-class) (:user-name "Source Abbreviation") (:default-print-slots 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)) (defclass uhier (umlsclass) ((cui :value-type fixnum :initarg :cui :reader cui :hyperlink find-ucon-cui :print-formatter fmt-cui) (aui :value-type fixnum :initarg :aui :reader aui :hyperlink find-ucon-aui :print-formatter fmt-aui) (cxn :value-type fixnum :initarg :cxn :reader cxn) (paui :value-type fixnum :initarg :paui :reader paui :print-formatter fmt-aui) (sab :value-type string :initarg :sab :reader sab :hyperlink find-usab-rsab) (rela :value-type string :initarg :rela :reader rela) (ptr :value-type string :initarg :ptr :reader ptr) (hcd :value-type string :initarg :hcd :reader hcd) (cvf :value-type string :initarg :cvf :reader cvf)) (:metaclass hyperobject-class) (:user-name "Context") (:default-print-slots cxn paui sab rela ptr hcd)) (defclass ustr (umlsclass) ((sui :value-type fixnum :initarg :sui :reader sui :print-formatter fmt-sui :hyperlink find-ustr-sui) (cui :value-type fixnum :initarg :cui :reader cui :print-formatter fmt-cui :hyperlink find-ucon-cui) (lui :value-type fixnum :initarg :lui :reader lui :print-formatter fmt-lui :hyperlink find-uterm-lui) (cuisui :value-type integer :initarg :cuisui :reader cuisui ) (str :value-type cdata :initarg :str :reader str) (lrl :value-type fixnum :initarg :lrl :reader lrl) (stt :value-type string :initarg :stt :reader stt) (suppress :value-type string :initarg :suppress :reader suppress) (s#so :reader s#so :subobject (find-uso-cuisui cui sui)) (s#sat :reader s#sat :subobject (find-usat-ui cui lui sui))) (:metaclass hyperobject-class) (: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 :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 :hyperlink find-ucon-sui) (saui :value-type string :initarg :saui :reader saui) (sdui :value-type string :initarg :sdui :reader sdui) (scui :value-type string :initarg :scui :reader scui) (tty :value-type string :initarg :tty :reader 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) (str :value-type cdata :initarg :str :reader str) (srl :value-type fixnum :initarg :srl :reader srl)) (:metaclass hyperobject-class) (:user-name "Source") (:default-print-slots aui sab code saui sdui scui tty srl)) (defclass uterm (umlsclass) ((lui :value-type fixnum :initarg :lui :reader lui :print-formatter fmt-lui :hyperlink find-uterm-lui) (cui :value-type fixnum :initarg :cui :reader cui :print-formatter fmt-cui :hyperlink find-ucon-cui) (lat :value-type string :initarg :lat :reader lat) (ts :value-type string :initarg :ts :reader ts) (lrl :value-type fixnum :initarg :lrl :reader lrl) (s#str :reader s#str :subobject (find-ustr-cuilui cui lui)) (s#sat :reader s#sat :subobject (find-usat-ui cui lui))) (:metaclass hyperobject-class) (:user-name "Term") (:default-print-slots lui lat ts lrl)) (defclass usty (umlsclass) ((tui :value-type fixnum :initarg :tui :reader tui :print-formatter fmt-tui :hyperlink find-ucon-tui :hyperlink-parameters (("subobjects" . "no"))) (sty :value-type string :initarg :sty :reader sty)) (:metaclass hyperobject-class) (:user-name "Semantic Type") (:default-print-slots tui sty)) (defclass urel (umlsclass) ((rel :value-type string :initarg :rel :reader rel :hyperlink find-brel-rel) (cui1 :value-type fixnum :initarg :cui1 :reader cui1 :print-formatter fmt-cui) (aui1 :value-type fixnum :initarg :aui1 :reader aui1 :print-formatter fmt-aui) (stype1 :value-type string :initarg :stype1 :reader stype1) (cui2 :value-type fixnum :initarg :cui2 :reader cui2 :hyperlink find-ucon-sui :print-formatter fmt-cui) (aui2 :value-type fixnum :initarg :aui2 :reader aui2 :hyperlink find-ucon-aui :print-formatter fmt-aui) (pfstr2 :value-type cdata :initarg :pfstr2 :reader pfstr2) (stype2 :value-type string :initarg :stype2 :reader stype2) (rela :value-type string :initarg :rela :reader rela) (rui :value-type fixnum :initarg :rui :reader rui :print-formatter fmt-rui) (srui :value-type string :initarg :srui :reader srui) (sab :value-type string :initarg :sab :reader sab :hyperlink find-usab-rsab) (sl :value-type string :initarg :sl :reader sl) (rg :value-type string :initarg :rg :reader rg) (dir :value-type string :initarg :dir :reader dir) (suppress :value-type string :initarg :suppress :reader suppress) (cvf :value-type string :initarg :cvf :reader cvf)) (:metaclass hyperobject-class) (:user-name "Relationship") (:default-print-slots stype1 rel cui2 aui2 stype2 rela rui srui sab sl rg dir suppress pfstr2)) (defclass ucoc (umlsclass) ((cui1 :value-type fixnum :initarg :cui1 :reader cui1 :print-formatter fmt-cui) (aui1 :value-type fixnum :initarg :aui1 :reader aui1 :print-formatter fmt-aui) (cui2 :value-type fixnum :initarg :cui2 :reader cui2 :print-formatter fmt-cui :hyperlink find-ucon-cui) (aui2 :value-type fixnum :initarg :aui2 :reader aui2 :print-formatter fmt-aui :hyperlink find-ucon-aui) (pfstr2 :value-type cdata :initarg :pfstr2 :reader pfstr2) (sab :value-type string :initarg :sab :reader sab) (cot :value-type string :initarg :cot :reader cot) (cof :value-type fixnum :initarg :cof :reader cof) (coa :value-type cdata :initarg :coa :reader coa) (cvf :value-type string :initarg :cvf :reader cvf)) (:metaclass hyperobject-class) (: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 :compute-cached-value (find-lrl-cui cui)) (pfstr :value-type cdata :initarg :pfstr :reader pfstr :compute-cached-value (find-pfstr-cui cui)) (s#def :reader s#def :subobject (find-udef-cui cui)) (s#so :reader s#so :subobject (find-uso-cui cui)) (s#hier :reader s#hier :subobject (find-uhier-cui cui)) (s#map :reader s#map :subobject (find-umap-cui cui)) (s#smap :reader s#smap :subobject (find-usmap-cui cui)) (s#sty :reader s#sty :subobject (find-usty-cui cui)) (s#term :reader s#term :subobject (find-uterm-cui cui)) (s#sat :reader s#sat :subobject (find-usat-ui cui)) (s#rel :reader s#rel :subobject (find-urel-cui cui)) (s#coc :reader s#coc :subobject (find-ucoc-cui cui))) (:metaclass hyperobject-class) (:user-name "Concept") (:default-print-slots cui lrl pfstr)) (defclass uconso (umlsclass) ((cui :value-type fixnum :initarg :cui :reader cui :print-formatter fmt-cui :hyperlink find-ucon-cui) (pfstr :value-type cdata :initarg :pfstr :reader pfstr :compute-cached-value (find-pfstr-cui cui)) (lat :value-type string :initarg :lat :reader lat) (ts :value-type string :initarg :ts :reader ts) (lui :value-type fixnum :initarg :lui :reader lui :print-formatter fmt-lui) (stt :value-type string :initarg :stt :reader stt) (sui :value-type fixnum :initarg :sui :reader sui :print-formatter fmt-sui) (ispref :value-type string :initarg :ispref :reader ispref) (aui :value-type fixnum :initarg :aui :reader aui :print-formatter fmt-aui) (saui :value-type string :initarg :saui :reader saui) (scui :value-type string :initarg :scui :reader scui) (sdui :value-type string :initarg :sdui :reader sdui) (sab :value-type string :initarg :sab :reader sab) (tty :value-type string :initarg :tty :reader tty) (code :value-type string :initarg :code :reader code) (str :value-type string :initarg :str :reader str) (srl :value-type fixnum :initarg :srl :reader srl) (suppress :value-type string :initarg :suppress :reader suppress) (cvf :value-type string :initarg :cvf :reader cvf) (kpfeng :value-type string :initarg :kpfeng :reader kpfeng) (kcuisui :value-type bigint :initarg :kcuisui :reader kcuisui) (kcuilui :value-type bigint :initarg :kcuilui :reader kcuilui) (kcuilrl :value-type fixnum :initarg :kcuilrl :reader kcuilrl) (kluilrl :value-type fixnum :initarg :kluilrl :reader kluilrl) (ksuilrl :value-type fixnum :initarg :ksuilrl :reader ksuilrl) (s#def :reader s#def :subobject (find-udef-cui cui)) (s#so :reader s#so :subobject (find-uso-cui cui)) (s#hier :reader s#hier :subobject (find-uhier-cui cui)) (s#map :reader s#map :subobject (find-umap-cui cui)) (s#smap :reader s#smap :subobject (find-usmap-cui cui)) (s#sty :reader s#sty :subobject (find-usty-cui cui)) (s#term :reader s#term :subobject (find-uterm-cui cui)) (s#sat :reader s#sat :subobject (find-usat-ui cui)) (s#rel :reader s#rel :subobject (find-urel-cui cui)) (s#coc :reader s#coc :subobject (find-ucoc-cui cui))) (:documentation "CONSO is a new concept from the RRF files. This object is a rather raw row from the MRCONSO table.") (:metaclass hyperobject-class) (:user-name "Concept") (:default-print-slots cui kcuilrl str sab)) (defclass umap (umlsclass) ((mapsetcui :value-type fixnum :initarg :mapsetcui :reader mapsetcui) (mapsetsab :value-type string :initarg :mapsetsab :reader mapsetsab) (mapsubsetid :value-type string :initarg :mapsubsetid :reader mapsubsetid) ;; fixme: will convert to integer (maprank :value-type string :initarg :maprank :reader maprank) (fromid :value-type string :initarg :fromid :reader fromid) (fromsid :value-type string :initarg :fromsid :reader fromsid) (fromexpr :value-type string :initarg :fromexpr :reader fromexpr) (fromtype :value-type string :initarg :fromtype :reader fromtype) (fromrule :value-type string :initarg :fromrule :reader fromrule) (fromres :value-type string :initarg :fromres :reader fromres) (rel :value-type string :initarg :rel :reader rel) (rela :value-type string :initarg :rela :reader rela) (toid :value-type string :initarg :toid :reader toid) (tosid :value-type string :initarg :tosid :reader tosid) (toexpr :value-type string :initarg :toexpr :reader toexpr) (totype :value-type string :initarg :totype :reader totype) (torule :value-type string :initarg :torule :reader torule) (tores :value-type string :initarg :tores :reader tores) (maprule :value-type string :initarg :maprule :reader maprule) (maptype :value-type string :initarg :maptype :reader maptype) (mapatn :value-type string :initarg :mapatn :reader mapatn) (mapatv :value-type string :initarg :mapatv :reader mapatv) (cvf :value-type string :initarg :cvf :reader cvf)) (:metaclass hyperobject-class) (:user-name "Mapping") (:default-print-slots mapsetcui mapsetsab mapsubsetid maprank fromid fromsid fromexpr fromtype fromrule fromres rel rela toid tosid toexpr totype torule tores maprule maptype mapatn mapatv)) (defclass usmap (umlsclass) ((mapsetcui :value-type fixnum :initarg :mapsetcui :reader mapsetcui) (mapsetsab :value-type string :initarg :mapsetsab :reader mapsetsab) (fromexpr :value-type string :initarg :fromexpr :reader fromexpr) (fromtype :value-type string :initarg :fromtype :reader fromtype) (rel :value-type string :initarg :rel :reader rel) (rela :value-type string :initarg :rela :reader rela) (toexpr :value-type string :initarg :toexpr :reader toexpr) (totype :value-type string :initarg :totype :reader totype) (cvf :value-type string :initarg :cvf :reader cvf)) (:metaclass hyperobject-class) (:user-name "Simple Mapping") (:default-print-slots mapsetcui mapsetsab fromexpr fromtype rel rela toexpr totype)) (defclass uxw (umlsclass) ((wd :value-type string :initarg :wd :reader wd) (cui :value-type fixnum :initform nil :initarg :cui :reader cui :print-formatter fmt-cui) (lui :value-type fixnum :initform nil :initarg :lui :reader lui :print-formatter fmt-lui) (sui :value-type fixnum :initform nil :initarg :sui :reader sui :print-formatter fmt-sui)) (:metaclass hyperobject-class) (:user-name "XW Index" "XW Indices") (:default-print-slots wd cui lui sui)) (defclass uxw-noneng (umlsclass) ((lat :value-type string :initarg :lat :reader lat) (wd :value-type string :initarg :wd :reader wd) (cui :value-type fixnum :initform nil :initarg :cui :reader cui :print-formatter fmt-cui) (lui :value-type fixnum :initform nil :initarg :lui :reader lui :print-formatter fmt-lui) (sui :value-type fixnum :initform nil :initarg :sui :reader sui :print-formatter fmt-sui) (lrl :value-type fixnum :initform nil :initarg :lrl :reader lrl)) (:metaclass hyperobject-class) (:user-name "XW Non-English Index" "XW Non-English Indices") (:default-print-slots wd cui lui sui)) (defclass uxnw (umlsclass) ((lat :value-type string :initarg :lat :reader lat) (nwd :value-type string :initarg :nwd :reader nwd) (cuilist :value-type list :initarg :cuilist :reader uxnw-cuilist)) (:metaclass hyperobject-class) (:user-name "XNW Index" "XNW Indices") (:default-print-slots lat nwd cuilist)) (defclass uxns (umlsclass) ((lat :value-type string :initarg :lat :reader lat) (nstr :value-type string :initarg :nstr :reader nstr) (cuilist :value-type list :initarg :cuilist :reader cuilist)) (:metaclass hyperobject-class) (: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 (defclass lexterm (umlsclass) ((eui :value-type fixnum :initarg :eui :reader eui :print-formatter fmt-eui :hyperlink find-lexterm-eui) (wrd :value-type string :initarg :wrd :reader wrd) (s#abr :reader s#abr :subobject (find-labr-eui eui)) (s#agr :reader s#agr :subobject (find-lagr-eui eui)) (s#cmp :reader s#cmp :subobject (find-lcmp-eui eui)) (s#mod :reader s#mod :subobject (find-lmod-eui eui)) (s#nom :reader s#nom :subobject (find-lnom-eui eui)) (s#prn :reader s#prn :subobject (find-lprn-eui eui)) (s#prp :reader s#prp :subobject (find-lprp-eui eui)) (s#spl :reader s#spl :subobject (find-lspl-eui eui)) (s#trm :reader s#trm :subobject (find-ltrm-eui eui)) (s#typ :reader s#typ :subobject (find-ltyp-eui eui))) (:metaclass hyperobject-class) (:user-name "Lexical Term") (:default-print-slots eui wrd)) (defclass labr (umlsclass) ((eui :value-type integer :initarg :eui :reader eui :print-formatter fmt-eui) (bas :value-type string :initarg :bas :reader bas) (abr :value-type string :initarg :abr :reader abr) (eui2 :value-type integer :initarg :eui2 :reader eui2 :print-formatter fmt-eui) (bas2 :value-type string :initarg :bas2 :reader bas2)) (:metaclass hyperobject-class) (:user-name "Abbreviations and Acronym") (:default-print-slots eui bas abr eui2 bas2)) (defclass lagr (umlsclass) ((eui :value-type integer :initarg :eui :reader eui :print-formatter fmt-eui) (str :value-type string :initarg :str :reader str) (sca :value-type string :initarg :sca :reader sca) (agr :value-type string :initarg :agr :reader agr) (cit :value-type string :initarg :cit :reader cit) (bas :value-type string :initarg :bas :reader bas)) (:metaclass hyperobject-class) (:user-name "Agreement and Inflection") (:default-print-slots eui str sca agr cit bas)) (defclass lcmp (umlsclass) ((eui :value-type integer :initarg :eui :reader eui :print-formatter fmt-eui) (bas :value-type string :initarg :bas :reader bas) (sca :value-type string :initarg :sca :reader sca) (com :value-type string :initarg :com :reader com)) (:metaclass hyperobject-class) (:user-name "Complementation") (:default-print-slots eui bas sca com)) (defclass lmod (umlsclass) ((eui :value-type integer :initarg :eui :reader eui :print-formatter fmt-eui) (bas :value-type string :initarg :bas :reader bas) (sca :value-type string :initarg :sca :reader sca) (psnmod :value-type string :initarg :psnmod :reader psnmod) (fea :value-type string :initarg :fea :reader fea)) (:metaclass hyperobject-class) (:user-name "Modifier") (:default-print-slots eui bas sca psnmod fea)) (defclass lnom (umlsclass) ((eui :value-type integer :initarg :eui :reader eui :print-formatter fmt-eui) (bas :value-type string :initarg :bas :reader bas) (sca :value-type string :initarg :sca :reader sca) (eui2 :value-type integer :initarg :eui2 :reader eui2 :print-formatter fmt-eui) (bas2 :value-type string :initarg :bas2 :reader bas2) (sca2 :value-type string :initarg :sca2 :reader sca2)) (:metaclass hyperobject-class) (:user-name "Nominalization") (:default-print-slots eui bas sca eui2 bas2 sca2)) (defclass lprn (umlsclass) ((eui :value-type integer :initarg :eui :reader eui :print-formatter fmt-eui) (bas :value-type string :initarg :bas :reader bas) (num :value-type string :initarg :num :reader num) (gnd :value-type string :initarg :gnd :reader gnd) (cas :value-type string :initarg :cas :reader cas) (pos :value-type string :initarg :pos :reader pos) (qnt :value-type string :initarg :qnt :reader qnt) (fea :value-type string :initarg :fea :reader fea)) (:metaclass hyperobject-class) (:user-name "Pronoun") (:default-print-slots eui bas num gnd cas pos qnt fea)) (defclass lprp (umlsclass) ((eui :value-type integer :initarg :eui :reader eui :print-formatter fmt-eui) (bas :value-type string :initarg :bas :reader bas) (str :value-type string :initarg :str :reader str) (sca :value-type string :initarg :sca :reader sca) (fea :value-type string :initarg :fea :reader fea)) (:metaclass hyperobject-class) (:user-name "Property" "Properties") (:default-print-slots eui bas str sca fea)) (defclass lspl (umlsclass) ((eui :value-type integer :initarg :eui :reader eui :print-formatter fmt-eui) (spv :value-type string :initarg :spv :reader spv) (bas :value-type string :initarg :bas :reader bas)) (:metaclass hyperobject-class) (:user-name "Spelling Variant") (:default-print-slots eui spv bas)) (defclass ltrm (umlsclass) ((eui :value-type integer :initarg :eui :reader eui :print-formatter fmt-eui) (bas :value-type string :initarg :bas :reader bas) (gen :value-type string :initarg :gen :reader gen)) (:metaclass hyperobject-class) (:user-name "Trade Mark") (:default-print-slots eui bas gen)) (defclass ltyp (umlsclass) ((eui :value-type integer :initarg :eui :reader eui :print-formatter fmt-eui) (bas :value-type string :initarg :bas :reader bas) (sca :value-type string :initarg :sca :reader sca) (typ :value-type string :initarg :typ :reader typ)) (:metaclass hyperobject-class) (:user-name "Inflection Type") (:default-print-slots eui bas sca typ)) (defclass lwd (umlsclass) ((wrd :value-type string :initarg :wrd :reader wrd) (euilist :value-type list :initarg :euilist :reader euilist)) (:metaclass hyperobject-class) (:user-name "Lexical Word Index" "Lexical Word Indices") (:default-print-slots wrd euilist)) ;;; Semantic NET objects (defclass sdef (umlsclass) ((rt :value-type string :initarg :rt :reader rt) (ui :value-type integer :initarg :ui :reader ui :print-formatter fmt-tui) (styrl :value-type string :initarg :styrl :reader styrl) (stnrtn :value-type string :initarg :stnrtn :reader stnrtn) (def :value-type string :initarg :def :reader def) (ex :value-type string :initarg :ex :reader ex) (un :value-type string :initarg :un :reader un) (rh :value-type string :initarg :rh :reader rh) (abr :value-type string :initarg :abr :reader abr) (rin :value-type string :initarg :rin :reader rin)) (:metaclass hyperobject-class) (:user-name "Basic information about Semantic Types and Relation") (:default-print-slots rt ui styrl stnrtn def ex un rh abr rin)) (defclass sstr (umlsclass) ((styrl :value-type string :initarg :styrl :reader styrl) (rl :value-type string :initarg :rl :reader rl) (styrl2 :value-type string :initarg :styrl2 :reader styrl2) (ls :value-type string :initarg :ls :reader ls)) (:metaclass hyperobject-class) (:user-name "Structure of the Network") (:default-print-slots styrl rl styrl2 ls)) (defclass sstre1 (umlsclass) ((ui :value-type integer :initarg :ui :reader ui :print-formatter fmt-tui) (ui2 :value-type integer :initarg :ui2 :reader ui2 :print-formatter fmt-tui) (ui3 :value-type integer :initarg :ui3 :reader ui3 :print-formatter fmt-tui)) (:metaclass hyperobject-class) (:user-name "Fully Inherited Set of Relation (TUIs)" "Fully Inherited Set of Relations (TUIs)") (:default-print-slots ui ui2 ui3)) (defclass sstre2 (umlsclass) ((sty :value-type string :initarg :ui :reader sty) (rl :value-type string :initarg :ui2 :reader rl) (sty2 :value-type string :initarg :ui3 :reader sty2)) (:metaclass hyperobject-class) (:user-name "Fully Inherited Set of Relation (strings)" "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.")) cl-umlisp-2007ac.2/composite.lisp0000644000175000017500000001543710667175521015746 0ustar kevinkevin;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: composite.lisp ;;;; Purpose: Composite Classes for UMLisp ;;;; Author: Kevin M. Rosenberg ;;;; Created: Apr 2000 ;;;; ;;;; $Id$ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2006 by Kevin M. Rosenberg, M.D. ;;;; ;;;; UMLisp users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU General Public License. ;;;; ************************************************************************* (in-package #:umlisp) ;;; Semantic type constants (defun find-tui-word (words) (aif (car (find-usty-word words)) (tui it) nil)) (memoize 'find-tui-word) (defun tui-disease-or-syndrome () (find-tui-word "disease or syndrome")) (defun tui-sign-or-symptom () (find-tui-word "sign or symptom")) (defun tui-finding () (find-tui-word "finding")) ;;;; Related concepts with specific tui lookup functions (defun ucon-is-tui? (ucon tui) "Returns t if ucon has a semantic type of tui" (find tui (s#sty ucon) :key #'tui)) (defun find-ucon2-tui (ucon tui cui2-func related-con-func) "Returns a list of related ucons that have specific tui" (remove-duplicates (filter #'(lambda (c) (aif (funcall cui2-func c) (let ((ucon2 (find-ucon-cui it))) (when (ucon-is-tui? ucon2 tui) ucon2)) nil)) (funcall related-con-func ucon)) :key #'cui)) (defun find-ucon2-coc-tui (ucon tui) "Return list of ucon's that have co-occuring concepts of semantic type tui" (find-ucon2-tui ucon tui #'cui2 #'s#coc)) (defun find-ucon2-rel-tui (ucon tui) "Return list of ucon's that have related concepts to ucon and semantic type tui" (find-ucon2-tui ucon tui #'cui2 #'s#rel)) ;;; Composite Objects (defclass freq (hyperobject) ((freq :value-type integer :initarg :freq :accessor freq :print-formatter fmt-comma-integer)) (:metaclass hyperobject-class) (:default-initargs :freq 0) (:user-name "Frequency class" "Frequency classes") (:default-print-slots freq) (:description "Base class containing frequency slot, used for multi-inherited objects")) (defclass ucon_freq (ucon freq) () (:metaclass hyperobject-class) (:user-name "Concept and Count" "Concepts and Counts") (:default-print-slots cui freq pfstr) (:description "Composite object of ucon/freq")) (defclass ustr_freq (ustr freq) () (:metaclass hyperobject-class) (:user-name "String and Count" "Strings and Counts") (:default-print-slots sui freq stt lrl str) (:description "Composite object of ustr/freq")) (defclass usty_freq (usty freq) () (:metaclass hyperobject-class) (:user-name "Semantic Type and Count" "Semantic Types and Counts") (:default-print-slots tui freq sty) (:description "Composite object of usty/freq")) (defun find-usty_freq-all () (let ((usty_freqs '())) (dolist (tuple (mutex-sql-query "select distinct TUI from MRSTY")) (let* ((tui (car tuple)) (freq (ensure-integer (caar (mutex-sql-query (format nil "select count(*) from MRSTY where TUI=~a" tui))))) (usty (find-usty-tui tui))) (push (make-instance 'usty_freq :sty (sty usty) :tui (tui usty) :freq freq) usty_freqs))) (sort usty_freqs #'> :key #'freq))) (defclass usrl_freq (usrl freq) () (:metaclass hyperobject-class) (:user-name "Source and Count" "Sources and Counts") (:default-print-slots sab freq srl) (:description "Composite object of usrl/freq")) ;; Frequency finding functions (defun find-usrl_freq-all () (let ((freqs '())) (dolist (usrl (find-usrl-all)) (let ((freq (ensure-integer (caar (mutex-sql-query (format nil "select count(*) from MRSO where SAB='~a'" (sab usrl))))))) (push (make-instance 'usrl_freq :sab (sab usrl) :srl (srl usrl) :freq freq) freqs))) (sort freqs #'> :key #'freq))) (defun find-ucon2_freq-coc-tui (ucon tui) "Return sorted list of tuples with ucon and freq that have co-occuring concepts of semantic type tui" (let ((ucon_freqs '())) (dolist (ucoc (s#coc ucon)) (aif (cui2 ucoc) (let ((ucon2 (find-ucon-cui it))) (when (ucon-is-tui? ucon2 tui) (push (make-instance 'ucon_freq :cui (cui ucon2) :lrl (lrl ucon2) :pfstr (pfstr ucon2) :freq (cof ucoc)) ucon_freqs))))) (setq ucon_freqs (delete-duplicates ucon_freqs :key #'cui)) (sort ucon_freqs #'> :key #'freq))) (defun find-ucon2-str&sty (str sty lookup-func) "Call lookup-func for ucon and usty for given str and sty" (let ((ucon (car (find-ucon-str str))) (usty (car (find-usty-word sty)))) (if (and ucon usty) (funcall lookup-func ucon (tui usty)) nil))) (defun find-ucon2-coc-str&sty (str sty) "Find all ucons that are a co-occuring concept for concept named str and that have semantic type of sty" (find-ucon2-str&sty str sty #'find-ucon2-coc-tui)) (defun find-ucon2-rel-str&sty (str sty) "Find all ucons that are a relationship to concept named str and that have semantic type of sty" (find-ucon2-str&sty str sty #'find-ucon2-rel-tui)) ;;; Most common relationships, co-occurances (defun find-ucon2_freq-tui-all (tui ucon2-tui-func) "Return sorted list of all ucon2 that have a semantic type tui with ucon that is also has sty of tui" (let ((ucon_freqs (make-array (1+ (find-cui-max)) :initial-element nil))) (dolist (ucon (find-ucon-tui tui)) ;; for all disease-or-syn (dolist (ucon2 (funcall ucon2-tui-func ucon tui)) ;; for each related disease (aif (aref ucon_freqs (cui ucon2)) (setf (freq it) (1+ (freq it))) (setf (aref ucon_freqs (cui ucon2)) (make-instance 'ucon_freq :cui (cui ucon2) :lrl (lrl ucon2) :pfstr (pfstr ucon2) :freq 1))))) (let ((ucon_freq-list '())) (dotimes (i (find-cui-max)) (declare (fixnum i)) (awhen (aref ucon_freqs i) (push it ucon_freq-list))) (sort ucon_freq-list #'> :key #'freq)))) (defun find-ucon2_freq-rel-tui-all (tui) "Sorted list of ucon_freq with semantic type tui that are rel's of ucons with semantic type tui" (find-ucon2_freq-tui-all tui #'find-ucon2-rel-tui)) (defun find-ucon2_freq-coc-tui-all (tui) (find-ucon2_freq-tui-all tui #'find-ucon2-coc-tui)) #+(or scl) (dolist (c '(ucon_freq ustr_freq usty_freq usrl_freq)) (let ((cl #+cmu (pcl:find-class c) #+scl (find-class c))) #+cmu (pcl:finalize-inheritance cl) #+scl (clos:finalize-inheritance cl))) cl-umlisp-2007ac.2/data-structures.lisp0000644000175000017500000000762610667175521017077 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: data-structures.lisp ;;;; Purpose: Basic data objects for UMLisp ;;;; Author: Kevin M. Rosenberg ;;;; Created: Apr 2000 ;;;; ;;;; $Id$ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2006 by Kevin M. Rosenberg, M.D. ;;;; ;;;; UMLisp users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU General Public License. ;;;; ************************************************************************* (in-package #:umlisp) ;;; Paths for files (defparameter *release* "2006AD") (defparameter *umls-path* (make-pathname :directory (list :absolute "srv" "umls" *release*)) "Path for base of UMLS data files") (defparameter *meta-dir* (make-pathname :directory '(:relative "META"))) (defparameter *lex-dir* (make-pathname :directory '(:relative "LEX"))) (defparameter *net-dir* (make-pathname :directory '(:relative "NET"))) (defparameter *meta-path* (merge-pathnames *meta-dir* *umls-path*)) (defparameter *lex-path* (merge-pathnames *lex-dir* *umls-path*)) (defparameter *net-path* (merge-pathnames *net-dir* *umls-path*)) (defun umls-path! (p) (setq *umls-path* (etypecase p (string (parse-namestring p)) (pathname p))) (setq *meta-path* (merge-pathnames *meta-dir* *umls-path*)) (setq *lex-path* (merge-pathnames *lex-dir* *umls-path*)) (setq *net-path* (merge-pathnames *net-dir* *umls-path*))) ;;; Structures for parsing UMLS text files (defparameter *umls-files* nil "List of umls file structures. Used when parsing text files.") (defparameter *umls-cols* nil "List of meta column structures. Used when parsing text files.") ;; Special variables (defvar *has-fixnum-class* (when (ignore-errors (find-class 'fixnum)) t)) (defvar *octet-sql-storage* t "Used to deciding field lengths. Use nil if using UTF-8 database encoding. But, UTF-8 will cause MySQL to double the bytes used for fixed field sizes.") ;; Preliminary objects to replace structures (defclass ufile () ((subdir :initarg :subdir :accessor subdir) (dir :initarg :dir :accessor dir) (fil :initarg :fil :accessor fil) (table :initarg :table :accessor table) (des :initarg :des :accessor des) (fmt :initarg :fmt :accessor fmt) (cls :initarg :cls :accessor cls) (rws :initarg :rws :accessor rws) (bts :initarg :bts :accessor bts) (fields :initarg :fields :accessor fields) (ucols :initarg :ucols :accessor ucols)) (:default-initargs :fil nil :table nil :des nil :fmt nil :cls nil :rws nil :bts nil :fields nil :ucols nil :subdir nil :dir nil) (:documentation "UMLS File")) (defclass ucol () ((col :initarg :col :accessor col) (des :initarg :des :accessor des) (ref :initarg :ref :accessor ref) (min :initarg :min :accessor cmin) (av :initarg :av :accessor av) (max :initarg :max :accessor cmax) (fil :initarg :fil :accessor fil) (sqltype :initarg :sqltype :accessor sqltype) (dty :initarg :dty :accessor dty :documentation "new in 2002: suggested SQL datatype") (parse-fun :initarg :parse-fun :accessor parse-fun) (quote-str :initarg :quote-str :accessor quote-str) (datatype :initarg :datatype :accessor datatype) (custom-value-fun :initarg :custom-value-fun :accessor custom-value-fun)) (:default-initargs :col nil :des nil :ref nil :min nil :av nil :max nil :fil nil :sqltype nil :dty nil :parse-fun nil :datatype nil :custom-value-fun nil) (:documentation "UMLS column")) (defmethod print-object ((obj ufile) (s stream)) (print-unreadable-object (obj s :type t) (format s "~A" (fil obj)))) (defmethod print-object ((obj ucol) (s stream)) (print-unreadable-object (obj s :type t) (format s "~A" (col obj)))) cl-umlisp-2007ac.2/package.lisp0000644000175000017500000001217510667175521015333 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: cl-user -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: package.lisp ;;;; Purpose: Package definition for UMLisp ;;;; Author: Kevin M. Rosenberg ;;;; Created: Apr 2000 ;;;; ;;;; $Id$ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2006 by Kevin M. Rosenberg, M.D. ;;;; ;;;; UMLisp users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU General Public License. ;;;; ************************************************************************* (in-package #:cl-user) (eval-when (:compile-toplevel :load-toplevel :execute) ;; enclose reader macro (defpackage #:umlisp (:nicknames #:u) (:use #:kmrcl #:common-lisp #:hyperobject) (:export #:dummy . ;; From classes.lisp #1=(#:umlsclass #:ucon #:uterm #:ustr #:usrl #:uso #:urank #:udef #:usat #:usab #:urel #:ucoc #:usty #:uxw #:uxnw #:uxns #:lexterm #:labr #:lagr #:lcmp #:lmod #:lnom #:lprn #:lprp #:lspl #:ltrm #:ltyp #:lwd #:sdef #:sstr #:sstre1 #:sstre2 #:sty #:tui #:def #:sab #:srl #:tty #:rank #:suppress #:atn #:atv #:vcui #:rcui #:vsab #:code #:saui #:scui #:sdui #:ispref #:rl #:sty2 #:ui #:ui2 #:ui3 #:eui #:bas #:eui2 #:bas2 #:rui #: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 #:pfstr #:pfstr2 #:lrl #:def #:ts #:cui1 #:cui2 #:rela #:sl #:mg #:rel #:soc #:cot #:cof #:coa #:isn #:fr #:un #:sna #:soui #:hcd #:stt #:str #:kpfeng :cvf ;; From class-support.lisp #:ucon-has-tui #:english-term-p #:remove-non-english-terms #:remove-english-terms #:fmt-cui #:fmt-tui #:fmt-sui #:fmt-eui #:fmt-tui #:fmt-aui #:display-con #:display-term #:display-str #:pfstr #:pf-ustr #:cui-p #:lui-p #:sui-p #:tui-p #:eui-p #:rel-abbr-info #:filter-urels-by-rel #:mesh-number #:ucon-ustrs #:lat-abbr-info #:stt-abbr-info #:uso-unique-codes #:ucon-has-sab ;; From sql.lisp #:*umls-sql-db* #:umls-sql-user! #:umls-sql-passwd! #:umls-sql-db! #:umls-sql-host! #:umls-sql-type! ;; From utils.lisp #:fmt-cui #:fmt-lui #:fmt-sui #:fmt-tui #:find-uterm-in-ucon #:find-ustr-in-uterm #:find-ustr-in-ucon #:*current-srl* #:parse-cui #:parse-lui #:parse-sui #:parse-tui #:parse-eui ;; From sql-classes.lisp #:find-udef-cui #:find-usty-cui #:find-usty-word #:find-urel-cui #:find-cui2-urel-cui #:find-urel-cui2 #:find-ucon-rel-cui2 #:find-ucoc-cui #:find-ucoc-cui2 #:find-ucon-coc-cui2 #:find-usty-sty #:suistr #:print-umlsclass #:find-ucon-cui #:make-ucon-cui #:find-uconso-cui #:find-uconso-sui #:find-uconso-code #:find-ucon-lui #:find-ucon-sui #:find-ucon-cuisui #:find-ucon-str #:find-ucon-all #:find-cui-ucon-all #:map-ucon-all #:find-uterm-cui #:find-uterm-lui #:find-uterm-cuilui #:find-uterm-in-ucon #:find-ustr-cuilui #:find-ustr-cuisui #:find-ustr-sui #:find-ustr-sab #:find-ustr-all #:find-string-sui #:find-uso-cuisui #:find-uso-cui #:find-uso-aui #:find-usat-ui #:find-usab-all #:find-usab-rsab #:find-usab-vsab #:find-pfstr-cui #:find-ustr-in-uterm #:find-usty-tui #:find-usty-all #:find-usty_freq-all #:find-usrl-all #:find-usrl_freq-all #:find-cui-max #:find-ucon-tui #:find-ucon-word #:find-ucon-normalized-word #:find-cui-normalized-word #:find-lui-normalized-word #:find-sui-normalized-word #:find-ustr-word #:find-ustr-normalized-word #:find-uterm-multiword #:find-uterm-word #:find-uterm-normalized-word #:find-ucon-multiword #:find-uconso-multiword #:find-ucon-normalized-multiword #:find-ustr-multiword #:find-ustr-normalized-multiword #:find-lexterm-eui #:find-lexterm-word #:find-labr-eui #:find-labr-bas #:find-lagr-eui #:find-lcmp-eui #:find-lmod-eui #:find-lnom-eui #:find-lprn-eui #:find-lprp-eui #:find-lspl-eui #:find-ltrm-eui #:find-ltyp-eui #:find-lwd-wrd #:find-sdef-ui #:find-sstre1-ui #:find-sstre1-ui2 #:find-sstr2-sty #:find-sstr-rl #:find-sstr-styrl #: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.lisp #:tui-finding #:tui-sign-or-symptom #:tui-disease-or-syndrome #:ucon-is-tui? #:find-ucon2-tui #:find-ucon2-coc-tui #:find-ucon2-rel-tui #:find-ucon2_freq-coc-tui #:find-ucon2-str&sty #:find-ucon2-coc-str&sty #:find-ucon2-rel-str&sty #:find-ucon2_freq-tui-all #:find-ucon2_freq-rel-tui-all #:find-ucon2_freq-coc-tui-all #:ucon_freq #:ustr_freq #:usty_freq #:usrl_freq ;; from data-structures.lisp #:umls-path! ))) (defpackage umlisp-user (:use #:kmrcl #:common-lisp #:hyperobject) (:import-from :umlisp . #1#) (:export . #1#) (:documentation "User package for UMLisp"))) cl-umlisp-2007ac.2/parse-common.lisp0000644000175000017500000003376110667175521016344 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: parse-common.lisp ;;;; Purpose: Common, stable parsing routines for UMLisp ;;;; Author: Kevin M. Rosenberg ;;;; Created: Apr 2000 ;;;; ;;;; $Id$ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2006 by Kevin M. Rosenberg, M.D. ;;;; ;;;; UMLisp users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU General Public License. ;;;; ************************************************************************* (in-package #:umlisp) (defun ensure-ucols+ufiles (&optional (alwaysclear nil)) "Initialize all UMLS file and column structures if not already initialized" (handler-case (when (or alwaysclear (null *umls-files*)) (setf *umls-cols* nil *umls-files* nil) (gen-ufiles) (gen-ucols) (set-ucols-for-ufiles *umls-files*) (ensure-field-lengths)) (error (e) (warn "Error reading ucols+ufiles: ~A." e) (setf *umls-cols* nil *umls-files* nil) nil)) t) (defun add-ucols (ucols) "Adds a ucol or list of ucols to *umls-cols*. Returns input value." (setq *umls-cols* (append (mklist ucols) *umls-cols*)) ucols) (defun add-ufiles (ufiles) "Adds a ufile or list of ufiles to *umls-filess*. Returns input value." (setq *umls-files* (append (mklist ufiles) *umls-files*)) ufiles) (defun ufile-pathname (ufile &optional (extension "")) "Return pathname for a umls filename with an optional extension" (assert (typep ufile 'ufile)) (let* ((dirs (append (list (dir ufile)) (awhen (subdir ufile) (list it)))) (name-list (delimited-string-to-list (fil ufile) #\.)) (name (if (second name-list) (first name-list) (concatenate 'string (first name-list) (or extension "")))) (type (when (second name-list) (concatenate 'string (second name-list) (or extension ""))))) (merge-pathnames (make-pathname :name name :type type :directory (cons :relative dirs)) *umls-path*))) (defun umls-pathname (filename &optional (extension "")) "Return pathname for a umls filename with an optional extension" (etypecase filename (string (let* ((name-list (delimited-string-to-list filename #\.)) (name (if (second name-list) (first name-list) (concatenate 'string (first name-list) (or extension "")))) (type (when (second name-list) (concatenate 'string (second name-list) (or extension ""))))) (merge-pathnames (make-pathname :name name :type type) (case (schar filename 0) ((#\M #\m) *meta-path*) ((#\L #\l) *lex-path*) ((#\S #\s) *net-path*) (t *umls-path*))))) (pathname filename))) ;;; Find field lengths for LEX and NET files (defun ensure-field-lengths () "Initial colstruct field lengths for files that don't have a measurement. Currently, these are the LEX and NET files." (dolist (length-list (ufiles-field-lengths (ufiles-to-measure))) (destructuring-bind (filename fields-max fields-av) length-list (let ((file (find-ufile filename))) (unless file (error "Can't find ~A filename in ufiles" filename)) (unless (= (length fields-max) (length (fields file))) (error "Number of file fields ~A not equal to field count in ufile ~S" fields-max file)) (dotimes (i (length (fields file))) (declare (fixnum i)) (let* ((field (nth i (fields file))) (col (find-ucol field filename))) (unless col (error "can't find column ~A" field)) (setf (cmax col) (aref fields-max i)) (setf (av col) (aref fields-av i)) (ensure-ucol-datatype col (datatype-for-colname (col col))))))))) (defun ufiles-to-measure () "Returns a list of ufiles to measure" (loop for ufile in *umls-files* unless (or (char= #\M (schar (fil ufile) 0)) (char= #\m (schar (fil ufile) 0))) collect ufile)) (defun ufiles-field-lengths (ufiles) "Returns a list of lists of containing (FILE MAX AV)" (loop for ufile in ufiles collect (file-field-lengths ufile))) (defun file-field-lengths (ufile) "Returns a list of FILENAME MAX AV" (declare (optimize (speed 3) (safety 0))) (let (fields-max fields-av num-fields (count-lines 0)) (declare (fixnum count-lines)) (with-umls-ufile (line ufile) (unless num-fields (setq num-fields (length line)) (setq fields-max (make-array num-fields :element-type 'fixnum :initial-element 0)) (setq fields-av (make-array num-fields :element-type '(or integer float) :initial-element 0))) (dotimes (i num-fields) (declare (fixnum i)) (let* ((str (nth i line)) (len (length #-(and clisp unicode) str #+(and clisp unicode) (if *octet-sql-storage* (ext:convert-string-to-bytes str charset:utf-8) str)))) #-(and clisp unicode) (declare (string str)) (declare (type (integer 0 10000000) len)) (incf (aref fields-av i) len) (when (> len (aref fields-max i)) (setf (aref fields-max i) len)))) (incf count-lines)) (dotimes (i num-fields) (setf (aref fields-av i) (float (/ (aref fields-av i) count-lines)))) (list (fil ufile) fields-max fields-av))) ;;; UMLS column/file functions (defun find-ucol-of-colname (colname filename ucols) "Returns list of umls-col structure for a column name and a filename" (dolist (ucol ucols nil) (when (and (string-equal filename (fil ucol)) (string-equal colname (col ucol))) (return-from find-ucol-of-colname ucol)))) (defun ensure-col-in-columns (colname filename ucols) (aif (find-ucol-of-colname colname filename ucols) it (add-ucols (make-ucol-for-column colname filename ucols)))) (defun make-ucol-for-column (colname filename ucols) ;; try to find column name without a terminal digit (let* ((len (length colname)) (last-digit? (digit-char-p (schar colname (1- len)))) (base-colname (if last-digit? (subseq colname 0 (1- len)) colname)) (ucol (when last-digit? (find-ucol-of-colname base-colname filename ucols)))) (when (and last-digit? (null ucol)) (error "Couldn't find a base column for col ~A in file ~A" colname filename)) (copy-or-new-ucol colname filename ucol))) (defun copy-or-new-ucol (colname filename ucol) (if ucol (make-instance 'ucol :col (copy-seq colname) :des (copy-seq (des ucol)) :ref (copy-seq (ref ucol)) :min (cmin ucol) :max (cmax ucol) :fil (copy-seq (fil ucol)) :sqltype (copy-seq (sqltype ucol)) :dty (copy-seq (dty ucol)) :parse-fun (parse-fun ucol) :quote-str (copy-seq (quote-str ucol)) :datatype (datatype ucol) :custom-value-fun (custom-value-fun ucol)) (make-empty-ucol colname filename))) (defun ensure-compiled-fun (fun) "Ensure that a function is compiled" (etypecase fun (null nil) (function (if (compiled-function-p fun) fun (compile nil fun))) (list (compile nil fun)))) (defun make-ucol (col des ref min av max fil dty &key (sqltype "VARCHAR") (parse-fun #'add-sql-quotes) (quote-str "'") (custom-value-fun)) (let ((ucol (make-instance 'ucol :col col :des des :ref ref :min min :av av :max (if (eql max 0) 1 max) ;; ensure at least one char wide :fil fil :dty dty :sqltype sqltype :quote-str quote-str :parse-fun (ensure-compiled-fun parse-fun) :custom-value-fun (ensure-compiled-fun custom-value-fun)))) (ensure-ucol-datatype ucol (datatype-for-colname col)) ucol)) (defun make-empty-ucol (colname filename) ;;(format "call in make-empty-ucol: ~A/~A" colname filename) (make-ucol (copy-seq colname) "Unknown" "" nil nil nil filename nil)) (defun find-ucol (colname filename) "Returns list of umls-col structure for a column name and a filename" (ensure-col-in-columns colname filename *umls-cols*)) (defun find-ufile (filename) "Returns umls-file structure for a filename" (find-if #'(lambda (f) (string= filename (fil f))) *umls-files*)) (defun position-field-file (filename fieldname) "Returns the position of a field in a file" (let ((ufile (find-ufile filename))) (unless ufile (warn "Unable to find ufile for filename ~A." filename) (return-from position-field-file nil)) (let ((pos (position fieldname (fields ufile) :test #'string=))) (unless pos (warn "Unable to find field ~A in ufile ~S." fieldname ufile) (return-from position-field-file nil)) pos))) (defun find-ucols-for-ufile (ufile) "Returns list of umls-cols for a file structure" (loop for colname in (fields ufile) collect (find-ucol colname (if (subdir ufile) (concatenate 'string (subdir ufile) "/" (fil ufile)) (fil ufile))))) (defun umls-field-string-to-list (fmt) "Converts a comma delimited list of fields into a list of field names. Will append a unique number (starting at 2) onto a column name that is repeated in the list" (let ((col-counts (make-hash-table :test 'equal))) (loop for colname in (delimited-string-to-list (escape-column-name fmt) #\,) collect (multiple-value-bind (value found) (gethash colname col-counts) (cond (found (incf (gethash colname col-counts)) (concatenate 'string colname (write-to-string (1+ value)))) (t (setf (gethash colname col-counts) 1) colname)))))) (defun decompose-fil (fil) (if fil (let ((pos (position #\/ fil))) (if pos (values (subseq fil (1+ pos)) (subseq fil 0 pos)) (values fil nil))) (values nil nil))) (defun filename-to-tablename (file) (let ((pos (search ".RRF" file))) (when pos (setf file (subseq file 0 pos)))) (substitute #\_ #\. file)) (defun make-ufile (dir fil des cls rws bts fields) (multiple-value-bind (file subdir) (decompose-fil fil) (let ((ufile (make-instance 'ufile :dir dir :fil file :subdir subdir :des des :cls cls :rws rws :bts bts :fields fields :table (filename-to-tablename file)))) ufile))) (defun set-ucols-for-ufiles (ufiles) (dolist (ufile ufiles) (setf (ucols ufile) (find-ucols-for-ufile ufile)))) (defun datatype-for-colname (colname) "Return datatype for column name" (second (find colname +col-datatypes+ :key #'car :test #'string-equal))) (defun canonicalize-column-type (type) (cond ((string-equal type "TINYINT") (case *umls-sql-type* (:mysql "TINYINT") ((:postgresql :postgresql-socket) "INT1") (:oracle "NUMBER(3,0)") (t "INTEGER"))) ((string-equal type "SMALLINT") (case *umls-sql-type* (:mysql "SMALLINT") ((:postgresql :postgresql-socket) "INT2") (:oracle "NUMBER(5,0)") (t "INTEGER"))) ((string-equal type "INTEGER") (case *umls-sql-type* (:mysql "INTEGER") ((:postgresql :postgresql-socket) "INT4") (:oracle "NUMBER(9,0)") (t "INTEGER"))) ((string-equal type "BIGINT") (case *umls-sql-type* (:mysql "BIGINT") ((:postgresql :postgresql-socket) "INT8") (:oracle "NUMBER(38,0)") (t "INTEGER"))) ((string-equal type "TEXT") (case *umls-sql-type* (:mysql "TEXT") ((:postgresql :postgresql-socket) "TEXT") (:oracle "VARCHAR2(3000)") (t "VARCHAR(3000)"))) ((string-equal type "VARCHAR") (case *umls-sql-type* (:mysql "VARCHAR") ((:postgresql :postgresql-socket) "VARCHAR") (:oracle "VARCHAR2") (t "VARCHAR"))) ((string-equal type "NUMERIC") (case *umls-sql-type* (:mysql "NUMERIC") ((:postgresql :postgresql-socket) "NUMERIC") (:oracle "NUMBER") (t "NUMERIC"))) (t type))) (defun ensure-ucol-datatype (col datatype) "Add data type information to column" (setf (datatype col) datatype) (case datatype (sql-u (setf (sqltype col) (canonicalize-column-type "INTEGER") (parse-fun col) #'parse-ui (quote-str col) "")) (sql-s (setf (sqltype col) (canonicalize-column-type "SMALLINT") (parse-fun col) #'parse-integer (quote-str col) "")) (sql-l (setf (sqltype col) (canonicalize-column-type "BIGINT") (parse-fun col) #'parse-integer (quote-str col) "")) (sql-i (setf (sqltype col) (canonicalize-column-type "INTEGER") (parse-fun col) #'parse-integer (quote-str col) "")) (sql-t (setf (sqltype col) (canonicalize-column-type "TINYINT") (parse-fun col) #'parse-integer (quote-str col) "")) (sql-f (setf (sqltype col) (canonicalize-column-type "NUMERIC") (parse-fun col) #'read-from-string (quote-str col) "")) (t ; Default column type, optimized text storage (setf (parse-fun col) #'add-sql-quotes (quote-str col) "'") (when (and (cmax col) (av col)) (if (> (cmax col) 255) (setf (sqltype col) (canonicalize-column-type "TEXT")) (setf (sqltype col) (canonicalize-column-type "VARCHAR"))))))) (defun escape-column-name (name) (substitute #\_ #\/ name)) cl-umlisp-2007ac.2/parse-macros.lisp0000644000175000017500000000777710667175521016350 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: parse-macros.lisp ;;;; Purpose: Macros for UMLS file parsing ;;;; Author: Kevin M. Rosenberg ;;;; Created: Apr 2000 ;;;; ;;;; $Id$ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2006 by Kevin M. Rosenberg, M.D. ;;;; ;;;; UMLisp users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU General Public License. ;;;; ************************************************************************* (in-package #:umlisp) (defun read-umls-line (strm &optional (eof 'eof)) "Read a line from a UMLS stream, split into fields" (let ((line (read-line strm nil eof))) (if (eq line eof) eof (delimited-string-to-list line #\| t)))) (defun source-files (path) (if (probe-file path) (list path) (sort (directory (make-pathname :defaults path :type :wild :name (concatenate 'string (pathname-name path) (aif (pathname-type path) (concatenate 'string "." it) "")))) #'(lambda (a b) (string-lessp (pathname-type a) (pathname-type b)))))) (defmacro with-buffered-reading-umls-file ((line path) &body body) "Opens a UMLS and processes each parsed line with (body) argument" (let ((ustream (gensym "STRM-")) (buffer (gensym "BUF-")) (eof (gensym "EOF-")) (files (gensym "FILES-"))) `(let ((,eof (gensym "EOFSYM-")) (,buffer (make-fields-buffer)) (,files (source-files ,path))) (with-open-file (,ustream (first ,files) :direction :input #+(and clisp unicode) :external-format #+(and clisp unicode) charset:utf-8) (do ((,line (read-buffered-fields ,buffer ,ustream #\| ,eof) (read-buffered-fields ,buffer ,ustream #\| ,eof))) ((eq ,line ,eof) t) (setq ,line (coerce ,line 'list)) (print ,line) ,@body))))) (defmacro with-reading-umls-file ((line path) &body body) "Opens a UMLS and processes each parsed line with (body) argument" (let ((ustream (gensym "STRM-")) (eof (gensym "EOF-")) (files (gensym "FILES-"))) `(let ((,eof (gensym "EOFSYM-")) (,files (source-files ,path))) (unless ,files (error "Can't find files for ~A~%" (namestring ,path))) (with-open-file (,ustream (first ,files) :direction :input #+(and clisp unicode) :external-format #+(and clisp unicode) charset:utf-8) (do ((,line (read-umls-line ,ustream ,eof) (read-umls-line ,ustream ,eof))) ((eq ,line ,eof) t) (locally (declare (type list ,line)) ,@body)))))) (defmacro with-umls-ufile ((line ufile) &body body) "Opens a UMLS and processes each parsed line with (body) argument" `(with-reading-umls-file (,line (ufile-pathname ,ufile)) ,@body)) (defmacro with-umls-file ((line ufile) &body body) "Opens a UMLS and processes each parsed line with (body) argument" `(with-reading-umls-file (,line (umls-pathname ,ufile)) ,@body)) (defmacro with-buffered-umls-file ((line filename) &body body) "Opens a UMLS and processes each parsed line with (body) argument" (let ((ustream (gensym "STRM-")) (buffer (gensym "BUF-")) (eof (gensym "EOF-"))) `(let ((,buffer (make-fields-buffer)) (,eof (gensym "EOFSYM-"))) (with-open-file (,ustream (umls-pathname ,filename) :direction :input) (do ((,line (read-buffered-fields ,buffer ,ustream #\| ,eof) (read-buffered-fields ,buffer ,ustream #\| ,eof))) ((eq ,line ,eof) t) ,@body))))) cl-umlisp-2007ac.2/parse-rrf.lisp0000644000175000017500000005346610667175521015651 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: parse-rrf.lisp ;;;; Purpose: Parsing and SQL insertion routines for UMLisp which may ;;;; change from year to year ;;;; Author: Kevin M. Rosenberg ;;;; Created: Apr 2000 ;;;; ;;;; $Id$ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2006 by Kevin M. Rosenberg, M.D. ;;;; ;;;; UMLisp users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU General Public License. ;;;; ************************************************************************* (in-package #:umlisp) ;;; Pre-read data for custom fields into hash tables (defvar *preparse-hash-init?* nil) (eval-when (:compile-toplevel :load-toplevel :execute) (declaim (inline srl-to-srlus)) (defun srl-to-srlus (srl) "Convert the standard SRL category to one oriented for use in the United States. Specifically, SRL 4 in the USA has license restrictions between SRL 1 and 2 when used in the United States. We create a new scale (SRLUS) where SRL to SRLUS mapping is: (0->0, 1->1, 4->2, 2->3, 3->4)." (declare (type (integer 0 100) srl)) (cond ((<= srl 1) srl) ((= srl 4) 2) ((= srl 2) 3) ((= srl 3) 4) (t srl))) (defvar *vff-position-hash* (make-hash-table :size 100 :test 'eq)) (defmacro vff (filename fieldname record) (let ((pos (gensym "POS-")) (found (gensym "FOUND-")) (key (kmrcl:ensure-keyword (concatenate 'string filename "^" fieldname)))) `(locally (declare (optimize (speed 3) (safety 0))) (multiple-value-bind (,pos ,found) (gethash ,key *vff-position-hash*) (declare (ignore ,found)) (if ,pos (locally (declare (type (integer 0 100000) ,pos)) (nth ,pos ,record)) (let ((,pos (position-field-file ,filename ,fieldname))) (unless ,pos (error "Did not find fieldname ~A in filename ~A." ,fieldname ,filename)) (locally (declare (type (integer 0 100000) ,pos)) (setf (gethash ,key *vff-position-hash*) ,pos) (nth ,pos ,record)))))))) (let ((pfstr-hash nil) ;; Preferred concept strings by CUI (cui-lrl-hash nil) ;; LRL by CUI (lui-lrl-hash nil) ;; LRL by LUI (sui-lrl-hash nil) ;; LRL by SUI (cuisui-lrl-hash nil) ;; LRL by CUISUI (cui-lrlus-hash nil) ;; LRLUS by CUI (lui-lrlus-hash nil) ;; LRLUS by LUI (sui-lrlus-hash nil) ;; LRLUS by SUI (cuisui-lrlus-hash nil) ;; LRL by CUISUI (sab-srl-hash nil) (sab-srlus-hash nil)) ;; SRL by SAB (defun clear-preparse-hash-tables () (clrhash pfstr-hash) (clrhash cui-lrl-hash) (clrhash lui-lrl-hash) (clrhash sui-lrl-hash) (clrhash cuisui-lrl-hash) (clrhash cui-lrlus-hash) (clrhash lui-lrlus-hash) (clrhash sui-lrlus-hash) (clrhash cuisui-lrlus-hash) (clrhash sab-srl-hash) (clrhash sab-srlus-hash)) (defun make-preparse-hash-table () (if sui-lrl-hash (clear-preparse-hash-tables) (setf pfstr-hash (make-hash-table :size 1500000) cui-lrl-hash (make-hash-table :size 1500000) lui-lrl-hash (make-hash-table :size 5000000) sui-lrl-hash (make-hash-table :size 6000000) cuisui-lrl-hash (make-hash-table :size 6000000) cui-lrlus-hash (make-hash-table :size 1500000) lui-lrlus-hash (make-hash-table :size 5000000) sui-lrlus-hash (make-hash-table :size 6000000) cuisui-lrlus-hash (make-hash-table :size 6000000) sab-srl-hash (make-hash-table :size 200 :test 'equal) sab-srlus-hash (make-hash-table :size 200 :test 'equal)))) (defun ensure-preparse (&optional (force-read nil)) (when (and *preparse-hash-init?* (not force-read)) (return-from ensure-preparse 'already-done)) (make-preparse-hash-table) (let ((counter 0)) (declare (fixnum counter) (ignorable counter)) (with-umls-file (line "MRCONSO.RRF") (let* ((cui (parse-ui (vff "MRCONSO.RRF" "CUI" line))) (lui (parse-ui (vff "MRCONSO.RRF" "LUI" line))) (sui (parse-ui (vff "MRCONSO.RRF" "SUI" line))) (sab (vff "MRCONSO.RRF" "SAB" line)) (srl (parse-integer (vff "MRCONSO.RRF" "SRL" line))) (srlus (srl-to-srlus srl)) (cuisui (make-cuisui cui sui))) #+sbcl (when (= 0 (mod (incf counter) 100000)) (sb-ext:gc :full t)) ;; pfstr deprecated by KPFENG field in MRCONSO #+nil (unless (gethash cui pfstr-hash) ;; if haven't stored pfstr for cui (when (and (string-equal (vff "MRCONSO.RRF" "LAT" line) "ENG") (string-equal (vff "MRCONSO.RRF" "TS" line) "P") (string-equal (vff "MRCONSO.RRF" "STT" line) "PF")) (setf (gethash cui pfstr-hash) (vff "MRCONSO.RRF" "STR" line)))) (set-lrl-hash cui srl cui-lrl-hash) (set-lrl-hash lui srl lui-lrl-hash) (set-lrl-hash sui srl sui-lrl-hash) (set-lrl-hash cuisui srl cuisui-lrl-hash) (set-lrl-hash cui srlus cui-lrlus-hash) (set-lrl-hash lui srlus lui-lrlus-hash) (set-lrl-hash sui srlus sui-lrlus-hash) (set-lrl-hash cuisui srlus cuisui-lrlus-hash) (multiple-value-bind (val found) (gethash sab sab-srl-hash) (declare (ignore val)) (unless found (setf (gethash sab sab-srl-hash) srl))) (multiple-value-bind (val found) (gethash sab sab-srlus-hash) (declare (ignore val)) (unless found (setf (gethash sab sab-srlus-hash) srlus)))))) (setq *preparse-hash-init?* t) t) #+nil (defun pfstr-hash (cui) (gethash cui pfstr-hash)) (defun cui-lrl (cui) (gethash cui cui-lrl-hash)) (defun lui-lrl (lui) (gethash lui lui-lrl-hash)) (defun sui-lrl (sui) (gethash sui sui-lrl-hash)) (defun cuisui-lrl (cuisui) (gethash cuisui cuisui-lrl-hash)) (defun cui-lrlus (cui) (gethash cui cui-lrlus-hash)) (defun lui-lrlus (lui) (gethash lui lui-lrlus-hash)) (defun sui-lrlus (sui) (gethash sui sui-lrlus-hash)) (defun cuisui-lrlus (cuisui) (gethash cuisui cuisui-lrlus-hash)) (defun sab-srl (sab) (aif (gethash sab sab-srl-hash) it 0)) (defun sab-srlus (sab) (aif (gethash sab sab-srlus-hash) it 0)) )) ;; closure (defun set-lrl-hash (key srl hash) "Set the least restrictive level in hash table" (declare (fixnum srl)) (multiple-value-bind (hash-lrl found) (gethash key hash) (declare (type (or null fixnum) hash-lrl) (boolean found)) (if (or (not found) (< srl hash-lrl)) (setf (gethash key hash) srl)))) ;; UMLS file and column structures ;;; SQL datatypes symbols ;;; sql-u - Unique identifier ;;; sql-t - Tiny integer (8-bit) ;;; sql-s - Small integer (16-bit) ;;; sql-i - Integer (32-bit) ;;; sql-l - Big integer (64-bit) ;;; sql-f - Floating point ;;; sql-c - Character data (defparameter +col-datatypes+ '(("AV" sql-f) ("BTS" sql-i) ("CLS" sql-i) ("COF" sql-i) ("CUI1" sql-u) ("AUI" sql-u) ("AUI1" sql-u) ("AUI2" sql-u) ("PCUI" sql-u) ("PLUI" sql-u) ("PAUI" sql-u) ("RUI" sql-u) ("CUI2" sql-u) ("CUI" sql-u) ("CXN" sql-s) ("FR" sql-i) ("LUI" sql-u) ("MAX" sql-s) ("MIN" sql-s) ("RANK" sql-s) ("REF" sql-c) ("PTR" sql-c) ("RNK" sql-s) ("RWS" sql-i) ("SRL" sql-t) ("SUI" sql-u) ("TUI" sql-u) ("MAPRANK" sql-s) ;;; Custom columns ("KCUISUI" sql-l) ("KCUILUI" sql-l) ("KSRL" sql-t) ("KSRLUS" sql-t) ("LRL" sql-t) ("LRLUS" sql-t) ("KCUILRL" sql-t) ("KLUILRL" sql-t) ("KSUILRL" sql-t) ("KLRL" sql-t) ("KCUILRLUS" sql-t) ("KLUILRLUS" sql-t) ("KSUILRLUS" sql-t) ("KLRLUS" sql-t) ;;; LEX columns ("EUI" sql-u) ("EUI2" sql-u) ;;; Semantic net columns ("UI" sql-u) ("UI2" sql-u) ("UI3" sql-u) ;; New fields for 2002AD ("RCUI" sql-u) ("VCUI" sql-u) ("CFR" sql-i) ("TFR" sql-i) ;; New fields for 2004AA ("MAPSETCUI" sql-u) ) "SQL data types for each non-string column") (defparameter +custom-tables+ nil #+ignore '(("KCON" "SELECT CUI,STR FROM MRCONSO WHERE STT='PF' AND TS='P' AND ISPREF='Y' AND LAT='ENG'")) "Custom tables to create") (defparameter +custom-cols+ '(#+nil ("MRCONSO.RRF" "KPFSTR" "TEXT" (slot-value (find-ucol "STR" "MRCONSO.RRF") 'max) (lambda (x) (pfstr-hash (parse-ui (vff "MRCONSO.RRF" "CUI" x))))) ;; Set to 1 if term is prefered term for english ("MRCONSO.RRF" "KPFENG" "TINYINT" 0 (lambda (x) (if (and (string-equal (vff "MRCONSO.RRF" "LAT" x) "ENG") (string-equal (vff "MRCONSO.RRF" "TS" x) "P") (string-equal (vff "MRCONSO.RRF" "STT" x) "PF")) "1" "0"))) ("MRCONSO.RRF" "KCUISUI" "BIGINT" 0 (lambda (x) (write-to-string (make-cuisui (parse-ui (vff "MRCONSO.RRF" "CUI" x)) (parse-ui (vff "MRCONSO.RRF" "SUI" x)))))) ("MRCONSO.RRF" "KCUILUI" "BIGINT" 0 (lambda (x) (write-to-string (make-cuilui (parse-ui (vff "MRCONSO.RRF" "CUI" x)) (parse-ui (vff "MRCONSO.RRF" "SUI" x)))))) ("MRCONSO.RRF" "KCUILRL" "TINYINT" 0 (lambda (x) (write-to-string (cui-lrl (parse-ui (vff "MRCONSO.RRF" "CUI" x)))))) ("MRCONSO.RRF" "KCUILRLUS" "TINYINT" 0 (lambda (x) (write-to-string (cui-lrlus (parse-ui (vff "MRCONSO.RRF" "CUI" x)))))) ("MRCONSO.RRF" "KLUILRL" "TINYINT" 0 (lambda (x) (write-to-string (lui-lrl (parse-ui (vff "MRCONSO.RRF" "LUI" x)))))) ("MRCONSO.RRF" "KLUILRLUS" "TINYINT" 0 (lambda (x) (write-to-string (lui-lrlus (parse-ui (vff "MRCONSO.RRF" "LUI" x)))))) ("MRCONSO.RRF" "KSUILRL" "TINYINT" 0 (lambda (x) (write-to-string (sui-lrl (parse-ui (vff "MRCONSO.RRF" "SUI" x)))))) ("MRCONSO.RRF" "KSUILRLUS" "TINYINT" 0 (lambda (x) (write-to-string (sui-lrlus (parse-ui (vff "MRCONSO.RRF" "SUI" x)))))) ("MRCONSO.RRF" "KSRLUS" "TINYINT" 0 (lambda (x) (write-to-string (srl-to-srlus (parse-integer (vff "MRCONSO.RRF" "SRL" x)))))) ("MRSAB.RRF" "KSRLUS" "TINYINT" 0 (lambda (x) (write-to-string (srl-to-srlus (parse-integer (vff "MRSAB.RRF" "SRL" x)))))) ("MRSTY.RRF" "KLRL" "TINYINT" 0 (lambda (x) (write-to-string (cui-lrl (parse-ui (vff "MRSTY.RRF" "CUI" x)))))) ("MRSTY.RRF" "KLRLUS" "TINYINT" 0 (lambda (x) (write-to-string (cui-lrlus (parse-ui (vff "MRSTY.RRF" "CUI" x)))))) ("MRCOC.RRF" "KLRL" "TINYINT" 0 (lambda (x) (write-to-string (max (cui-lrl (parse-ui (vff "MRCOC.RRF" "CUI1" x))) (kmrcl:aif (cui-lrl (parse-ui (vff "MRCOC.RRF" "CUI2" x))) kmrcl::it 0))))) ("MRCOC.RRF" "KLRLUS" "TINYINT" 0 (lambda (x) (write-to-string (max (cui-lrlus (parse-ui (vff "MRCOC.RRF" "CUI1" x))) (kmrcl:aif (cui-lrl (parse-ui (vff "MRCOC.RRF" "CUI2" x))) kmrcl::it 0))))) ("MRSAT.RRF" "KSRL" "TINYINT" 0 (lambda (x) (write-to-string (sab-srl (vff "MRSAT.RRF" "SAB" x))))) ("MRSAT.RRF" "KSRLUS" "TINYINT" 0 (lambda (x) (write-to-string (sab-srlus (vff "MRSAT.RRF" "SAB" x))))) ("MRREL.RRF" "KSRL" "TINYINT" 0 (lambda (x) (write-to-string (sab-srl (vff "MRREL.RRF" "SAB" x))))) ("MRREL.RRF" "KSRLUS" "TINYINT" 0 (lambda (x) (write-to-string (sab-srlus (vff "MRREL.RRF" "SAB" x))))) ("MRRANK.RRF" "KSRL" "TINYINT" 0 (lambda (x) (write-to-string (sab-srl (vff "MRRANK.RRF" "SAB" x))))) ("MRRANK.RRF" "KSRLUS" "TINYINT" 0 (lambda (x) (write-to-string (sab-srlus (vff "MRRANK.RRF" "SAB" x))))) ("MRHIER.RRF" "KSRL" "TINYINT" 0 (lambda (x) (write-to-string (sab-srl (vff "MRHIER.RRF" "SAB" x))))) ("MRHIER.RRF" "KSRLUS" "TINYINT" 0 (lambda (x) (write-to-string (sab-srlus (vff "MRHIER.RRF" "SAB" x))))) ("MRMAP.RRF" "KSRL" "TINYINT" 0 (lambda (x) (write-to-string (sab-srl (vff "MRMAP.RRF" "MAPSETSAB" x))))) ("MRMAP.RRF" "KSRLUS" "TINYINT" 0 (lambda (x) (write-to-string (sab-srlus (vff "MRMAP.RRF" "MAPSETSAB" x))))) ("MRSMAP.RRF" "KSRL" "TINYINT" 0 (lambda (x) (write-to-string (sab-srl (vff "MRSMAP.RRF" "MAPSETSAB" x))))) ("MRSMAP.RRF" "KSRLUS" "TINYINT" 0 (lambda (x) (write-to-string (sab-srlus (vff "MRSMAP.RRF" "MAPSETSAB" x))))) ("MRDEF.RRF" "KSRL" "TINYINT" 0 (lambda (x) (write-to-string (sab-srl (vff "MRDEF.RRF" "SAB" x))))) ("MRDEF.RRF" "KSRLUS" "TINYINT" 0 (lambda (x) (write-to-string (sab-srlus (vff "MRDEF.RRF" "SAB" x))))) ("MRXW_ENG.RRF" "KLRL" "TINYINT" 0 (lambda (x) (write-to-string (cuisui-lrl (make-cuisui (parse-ui (vff "MRXW_ENG.RRF" "CUI" x)) (parse-ui (vff "MRXW_ENG.RRF" "SUI" x))))))) ("MRXW_ENG.RRF" "KLRLUS" "TINYINT" 0 (lambda (x) (write-to-string (cuisui-lrlus (make-cuisui (parse-ui (vff "MRXW_ENG.RRF" "CUI" x)) (parse-ui (vff "MRXW_ENG.RRF" "SUI" x))))))) ("MRXW_NONENG.RRF" "KLRL" "TINYINT" 0 (lambda (x) (write-to-string (cuisui-lrl (make-cuisui (parse-ui (vff "MRXW_NONENG.RRF" "CUI" x)) (parse-ui (vff "MRXW_NONENG.RRF" "SUI" x))))))) ("MRXW_NONENG.RRF" "KLRLUS" "TINYINT" 0 (lambda (x) (write-to-string (cuisui-lrlus (make-cuisui (parse-ui (vff "MRXW_NONENG.RRF" "CUI" x)) (parse-ui (vff "MRXW_NONENG.RRF" "SUI" x))))))) ("MRXNW_ENG.RRF" "KLRL" "TINYINT" 0 (lambda (x) (write-to-string (cuisui-lrl (make-cuisui (parse-ui (vff "MRXNW_ENG.RRF" "CUI" x)) (parse-ui (vff "MRXNW_ENG.RRF" "SUI" x))))))) ("MRXNW_ENG.RRF" "KLRLUS" "TINYINT" 0 (lambda (x) (write-to-string (cuisui-lrlus (make-cuisui (parse-ui (vff "MRXNW_ENG.RRF" "CUI" x)) (parse-ui (vff "MRXNW_ENG.RRF" "SUI" x))))))) ("MRXNS_ENG.RRF" "KLRL" "TINYINT" 0 (lambda (x) (write-to-string (cuisui-lrl (make-cuisui (parse-ui (vff "MRXNS_ENG.RRF" "CUI" x)) (parse-ui (vff "MRXNS_ENG.RRF" "SUI" x))))))) ("MRXNS_ENG.RRF" "KLRLUS" "TINYINT" 0 (lambda (x) (write-to-string (cuisui-lrlus (make-cuisui (parse-ui (vff "MRXNS_ENG.RRF" "CUI" x)) (parse-ui (vff "MRXNS_ENG.RRF" "SUI" x))))))) #+nil ("MRREL.RRF" "KPFSTR2" "TEXT" 1024 (lambda (x) (pfstr-hash (parse-ui (vff "MRREL.RRF" "CUI2" x))))) #+nil ("MRCOC.RRF" "KPFSTR2" "TEXT" 1024 (lambda (x) (pfstr-hash (parse-ui (vff "MRCOC.RRF" "CUI2" x))))) ("MRSAT.RRF" "KCUILUI" "BIGINT" 0 (lambda (x) (write-to-string (make-cuilui (parse-ui (vff "MRSAT.RRF" "CUI" x)) (parse-ui (vff "MRSAT.RRF" "LUI" x)))))) ("MRSAT.RRF" "KCUISUI" "BIGINT" 0 (lambda (x) (write-to-string (make-cuisui (parse-ui (vff "MRSAT.RRF" "CUI" x)) (parse-ui (vff "MRSAT.RRF" "SUI" x)))))) ("MRXW_ENG.RRF" "KCUISUI" "BIGINT" 0 (lambda (x) (write-to-string (make-cuisui (parse-ui (vff "MRXW_ENG.RRF" "CUI" x)) (parse-ui (vff "MRXW_ENG.RRF" "SUI" x)))))) ("MRXNW_ENG.RRF" "KCUISUI" "BIGINT" 0 (lambda (x) (write-to-string (make-cuisui (parse-ui (vff "MRXNW_ENG.RRF" "CUI" x)) (parse-ui (vff "MRXNW_ENG.RRF" "SUI" x)))))) ("MRXNS_ENG.RRF" "KCUISUI" "BIGINT" 0 (lambda (x) (write-to-string (make-cuisui (parse-ui (vff "MRXNS_ENG.RRF" "CUI" x)) (parse-ui (vff "MRXNS_ENG.RRF" "SUI" x)))))) ("MRXW_NONENG.RRF" "LAT" "VARCHAR" 3 (lambda (x) (vff "MRXW_NONENG.RRF" "LAT" x))) ("MRXW_NONENG.RRF" "WD" "VARCHAR" 200 (lambda (x) (vff "MRXW_NONENG.RRF" "WD" x))) ("MRXW_NONENG.RRF" "CUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (vff "MRXW_NONENG.RRF" "CUI" x))))) ("MRXW_NONENG.RRF" "LUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (vff "MRXW_NONENG.RRF" "LUI" x))))) ("MRXW_NONENG.RRF" "SUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (vff "MRXW_NONENG.RRF" "SUI" x))))) ("MRXW_NONENG.RRF" "KCUISUI" "BIGINT" 0 (lambda (x) (write-to-string (make-cuisui (parse-ui (vff "MRXW_NONENG.RRF" "CUI" x)) (parse-ui (vff "MRXW_NONENG.RRF" "SUI" x))))))) "Custom columns to create.(filename, col, sqltype, value-func).") (defparameter +index-cols+ '(("CUI1" "MRCOC") ("CUI" "MRCONSO") ("LUI" "MRCONSO") ("SRL" "MRCONSO") ("KSRLUS" "MRCONSO") ("AUI" "MRCONSO") ("KPFENG" "MRCONSO") ("SUI" "MRCONSO") ("SAUI" "MRCONSO") ("CODE" "MRCONSO") ("SCUI" "MRCONSO") ("CUI" "MRDEF") ("CUI1" "MRREL") ("CUI2" "MRREL") ("SAB" "MRREL") ("RUI" "MRREL") ("AUI1" "MRREL") ("AUI2" "MRREL") ("CUI" "MRSAT") ("LUI" "MRSAT") ("SUI" "MRSAT") ("METAUI" "MRSAT") ("ATN" "MRSAT") ("CUI" "MRSTY") ("TUI" "MRSTY") ("CUI" "MRXNS_ENG") ("AUI" "MRHIER") ("CUI" "MRHIER") ("CXN" "MRHIER") ("RELA" "MRHIER") ("PAUI" "MRHIER") ("SAB" "MRHIER") #+ignore ("NSTR" "MRXNS_ENG" 10) ("CUI" "MRXNW_ENG") ("NWD" "MRXNW_ENG") ("WD" "MRXW_ENG") ("KCUISUI" "MRCONSO") ("KCUILUI" "MRCONSO") ("KCUILRL" "MRCONSO") ("KLUILRL" "MRCONSO") ("KSUILRL" "MRCONSO") ("KCUILRLUS" "MRCONSO") ("KLUILRLUS" "MRCONSO") ("KSUILRLUS" "MRCONSO") ("KCUISUI" "MRSAT") ("KCUILUI" "MRSAT") ("KCUISUI" "MRXW_ENG") ("KCUISUI" "MRXNW_ENG") ("KCUISUI" "MRXNS_ENG") ("KCUISUI" "MRXW_NONENG") ("KSRL" "MRDEF") ("KSRL" "MRRANK")("KSRL" "MRREL") ("KSRL" "MRSAT") ("KSRLUS" "MRDEF") ("KSRLUS" "MRRANK")("KSRLUS" "MRREL") ("KSRLUS" "MRSAT") ("KLRL" "MRCOC") ("KLRL" "MRSTY") ("KLRL" "MRXW_ENG") ("KLRL" "MRXNW_ENG") ("KLRLUS" "MRCOC") ("KLRLUS" "MRSTY") ("KLRLUS" "MRXW_ENG") ("KLRLUS" "MRXNW_ENG") ("KLRL" "MRXNS_ENG") ("KLRL" "MRXW_NONENG") ("KLRLUS" "MRXNS_ENG") ("KLRLUS" "MRXW_NONENG") ;; LEX indices ("EUI" "LRABR") ("EUI2" "LRABR") ("EUI" "LRAGR") ("EUI" "LRCMP") ("EUI" "LRMOD") ("EUI" "LRNOM") ("EUI2" "LRNOM") ("EUI" "LRPRN") ("EUI" "LRPRP") ("EUI" "LRSPL") ("EUI" "LRTRM") ("EUI" "LRTYP") ("EUI" "LRWD") ("WRD" "LRWD") ("BAS" "LRABR") ;; Semantic NET indices ("UI" "SRSTRE1") ("UI2" "SRSTRE1") ("UI3" "SRSTRE1") ("STY_RL" "SRDEF") ("RT" "SRDEF") ("STY_RL" "SRSTR") ("STY_RL2" "SRSTR") ("RL" "SRSTR") ("SRL" "MRSAB") ("KSRLUS" "MRSAB") ("RSAB" "MRSAB") ("VSAB" "MRSAB") ("RCUI" "MRSAB") ("VCUI" "MRSAB") ("LAT" "MRSAB") ("MAPSETCUI" "MRMAP") ("MAPSETCUI" "MRSMAP") ("CUI" "MRHIER")) "Columns in files to index") (defparameter +custom-index-cols+ nil #+ignore '(("CUI" "KCON") ("LRL" "KCON")) "Indexes to custom tables") ;; File & Column functions (defun gen-ucols () (add-ucols (gen-ucols-meta)) (add-ucols (gen-ucols-generic "LRFLD")) (add-ucols (gen-ucols-generic "SRFLD")) (add-ucols (gen-ucols-custom))) (defun gen-ucols-meta () "Initialize all umls columns" (let ((cols '())) (with-umls-file (line "MRCOLS.RRF") (destructuring-bind (col des ref min av max fil dty) line (push (make-ucol col des ref (parse-integer min) (read-from-string av) (parse-integer max) fil dty) cols))) (nreverse cols))) (defun gen-ucols-custom () "Initialize umls columns for custom columns" (loop for customcol in +custom-cols+ collect (make-ucol (nth 1 customcol) "" 0 0 0 (eval (nth 3 customcol)) (nth 0 customcol) nil :sqltype (canonicalize-column-type (nth 2 customcol)) :custom-value-fun (compile nil (nth 4 customcol))))) (defun gen-ucols-generic (col-filename) "Initialize for generic (LEX/NET) columns" (let ((cols '())) (with-umls-file (line col-filename) (destructuring-bind (nam des ref fil) line (setq nam (escape-column-name nam)) (dolist (file (delimited-string-to-list fil #\,)) (push (make-ucol nam des ref nil nil nil file nil) cols)))) (nreverse cols))) (defun gen-ufiles () (add-ufiles (gen-ufiles-generic "MRFILES.RRF" "META")) (add-ufiles (gen-ufiles-generic "LRFIL" "LEX")) (add-ufiles (gen-ufiles-generic "SRFIL" "NET")) ;; needs to come last (add-ufiles (gen-ufiles-custom))) (defun gen-ufiles-generic (files-filename dir) "Initialize generic UMLS file structures" (let ((files '())) (with-umls-file (line files-filename) (destructuring-bind (fil des fmt cls rws bts) line (push (make-ufile dir fil des (parse-integer cls) (parse-integer rws) (parse-integer bts) (concatenate 'list (umls-field-string-to-list fmt) (custom-colnames-for-filename fil))) files))) (nreverse files))) (defun gen-ufiles-custom () (make-ufile "META" "MRXW_NONENG.RRF" "Custom NonEnglish Index" 5 0 0 (fields (find-ufile "MRXW_ENG.RRF")))) cl-umlisp-2007ac.2/run-tests.lisp0000644000175000017500000000276310667175521015706 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: parse-macros.lisp ;;;; Purpose: Macros for UMLS file parsing ;;;; Author: Kevin M. Rosenberg ;;;; Created: Apr 2000 ;;;; ;;;; $Id$ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2006 by Kevin M. Rosenberg, M.D. ;;;; ;;;; UMLisp users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU General Public License. ;;;; ************************************************************************* (defpackage #:run-tests (:use #:cl)) (in-package #:run-tests) (require 'rt) (require 'kmrcl) (require 'clsql-mysql) (require 'clsql) (require 'hyperobject) (load "umlisp.asd") (load "umlisp-tests.asd") (asdf:operate 'asdf:test-op 'umlisp) (defun quit (&optional (code 0)) "Function to exit the Lisp implementation. Copied from CLOCC's QUIT function." #+allegro (excl:exit code) #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code) #+(or cmu scl) (ext:quit code) #+cormanlisp (win32:exitprocess code) #+gcl (lisp:bye code) #+lispworks (lw:quit :status code) #+lucid (lcl:quit code) #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1))) #+mcl (ccl:quit code) #-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl) (error 'not-implemented :proc (list 'quit code))) (quit) cl-umlisp-2007ac.2/sql-classes.lisp0000644000175000017500000014445110667175521016175 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: sql-classes.lisp ;;;; Purpose: Routines for reading UMLS objects from SQL database ;;;; Author: Kevin M. Rosenberg ;;;; Created: Apr 2000 ;;;; ;;;; $Id$ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2006 by Kevin M. Rosenberg, M.D. ;;;; ;;;; UMLisp users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU General Public License. ;;;; ************************************************************************* (in-package #:umlisp) (defvar *current-srl* nil) (defun current-srl () *current-srl*) (defun current-srl! (srl) (setq *current-srl* srl)) (defmacro query-string (table fields srl where-name where-value &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)) (%%where (when where-name (format nil " WHERE ~:@(~A~)~A" where-name (if like " like " "")))) (%filter (gensym "FILTER-")) (%single (gensym "SINGLE-")) (%limit (gensym "LIMIT-"))) `(let ((,%limit ,limit) (,%single ,single) (,%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 ,(if %%where " AND " " WHERE ") ,%filter) "") (if ,srl (concatenate 'string ,%%lrl (write-to-string ,srl)) "") ,@(when %%order (list %%order)) (cond ((and ,%single ,%limit) (error "Can't set single (~S) and limit (~S)" ,%single ,%limit)) (,%single " LIMIT 1") (,%limit (format nil " LIMIT ~D" ,%limit)) (t "")))))) (defun query-string-eval (table fields srl where-name where-value &key (lrl "KCUILRL") single distinct order like limit filter) (when single (setq limit 1)) (concatenate 'string (format nil "SELECT ~A~{~:@(~A~)~^,~} FROM ~:@(~A~)" (if distinct "DISTINCT " "") fields table) (if where-name (format nil " WHERE ~:@(~A~)" where-name) "") (if where-name (format nil (typecase where-value (number "='~D'") (null " IS NULL") (t (if like " LINK '%~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 limit (format nil " LIMIT ~D" limit) ""))) (defmacro umlisp-query (table fields srl where-name where-value &key (lrl "KCUILRL") single distinct order like 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 :filter ,filter :limit ,limit))) (defmacro umlisp-query-eval (table fields srl where-name where-value &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 :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) filter limit) &body body) (let ((value (gensym)) (r (gensym))) (if single (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 :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 :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 filter limit) &body body) (let ((value (gensym)) (r (gensym)) (eval-fields (cadr fields))) (if single `(let* ((,value ,where-value) (tuple (car (umlisp-query-eval ,table ,fields ,srl ,where-name ,value :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like :filter ,filter :limit ,limit)))) (when tuple (destructuring-bind ,eval-fields tuple ,@body))) `(let ((,value ,where-value) (,r '())) (dolist (tuple (umlisp-query-eval ,table ,fields ,srl ,where-name ,value :lrl ,lrl :single ,single :distinct ,distinct :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 :filter ,filter :limit ,limit) collect (destructuring-bind ,eval-fields tuple ,@body)))))) ;;; ;;; Read from SQL database (defmacro ensure-cui-integer (cui) `(if (stringp ,cui) (setq ,cui (parse-cui ,cui)) ,cui)) (defmacro ensure-lui-integer (lui) `(if (stringp ,lui) (setq ,lui (parse-lui ,lui)) ,lui)) (defmacro ensure-sui-integer (sui) `(if (stringp ,sui) (setq ,sui (parse-sui ,sui)) ,sui)) (defmacro ensure-aui-integer (aui) `(if (stringp ,aui) (setq ,aui (parse-aui ,aui)) ,aui)) (defmacro ensure-rui-integer (rui) `(if (stringp ,rui) (setq ,rui (parse-rui ,rui)) ,rui)) (defmacro ensure-tui-integer (tui) `(if (stringp ,tui) (setq ,tui (parse-tui ,tui)) ,tui)) (defmacro ensure-eui-integer (eui) `(if (stringp ,eui) (setq ,eui (parse-eui ,eui)) ,eui)) (defun make-ucon-cui (cui) (ensure-cui-integer cui) (when cui (make-instance 'ucon :cui cui))) (defun find-ucon-cui (cui &key (srl *current-srl*) without-pfstr) "Find ucon for a cui. If set SAB, the without-pfstr is on by default" (ensure-cui-integer cui) (unless cui (return-from find-ucon-cui nil)) (if without-pfstr (collect-umlisp-query (mrconso (kcuilrl) srl cui cui :single t) (make-instance 'ucon :cui cui :lrl (ensure-integer kcuilrl) :pfstr nil))) (or (collect-umlisp-query (mrconso (kcuilrl str) srl cui cui :single t :filter "KPFENG=1") (make-instance 'ucon :cui cui :pfstr str :lrl kcuilrl)) (collect-umlisp-query (mrconso (kcuilrl str) srl cui cui :single t) (make-instance 'ucon :cui cui :pfstr str :lrl kcuilrl)))) (defun find-uconso-cui (cui &key sab (srl *current-srl*)) "Find uconso for a cui." (ensure-cui-integer cui) (unless cui (return-from find-uconso-cui nil)) (collect-umlisp-query (mrconso (lat ts lui stt sui ispref aui saui scui sdui sab tty code str srl suppress cvf kpfeng kcuisui kcuilui kcuilrl kluilrl ksuilrl) srl cui cui :filter (if sab (concatenate 'string "SAB='" sab "'") nil)) (make-instance 'uconso :cui cui :lat lat :ts ts :lui lui :stt stt :sui sui :ispref ispref :aui aui :saui saui :scui scui :sdui sdui :sab sab :tty tty :code code :str str :srl srl :suppress suppress :cvf cvf :kpfeng kpfeng :kcuisui kcuisui :kcuilui kcuilui :kcuilrl kcuilrl :kluilrl kluilrl :ksuilrl ksuilrl))) (defun find-uconso-code (code &key first sab (srl *current-srl*) (like nil)) "Return list of uconso objects that match code. Optional, filter for SAB. Optionally, use SQL's LIKE syntax" (collect-umlisp-query (mrconso (cui sab) srl code code :like like :distinct t :lrl klrl :filter (if sab (concatenate 'string "SAB='" sab "'") nil)) (let ((uconsos (find-uconso-cui cui :sab sab :srl srl))) (if first (first uconsos) uconsos)))) (defun find-uconso-sui (sui &key sab (srl *current-srl*)) "Find uconso for a sui. If set SAB, the without-pfstr is on by default" (ensure-sui-integer sui) (unless (and sui (stringp sab)) (return-from find-uconso-sui nil)) (collect-umlisp-query (mrconso (cui lat ts lui stt sui ispref aui saui scui sdui sab tty code str srl suppress cvf kpfeng kcuisui kcuilui kcuilrl kluilrl ksuilrl) srl sui sui :distinct t :filter (if sab (concatenate 'string "SAB='" sab "'") nil)) (make-instance 'uconso :cui cui :lat lat :ts ts :lui lui :stt stt :sui sui :ispref ispref :aui aui :saui saui :scui scui :sdui sdui :sab sab :tty tty :code code :str str :srl srl :suppress suppress :cvf cvf :kpfeng kpfeng :kcuisui kcuisui :kcuilui kcuilui :kcuilrl kcuilrl :kluilrl kluilrl :ksuilrl ksuilrl))) (defun find-pfstr-cui (cui &key (srl *current-srl*)) "Find preferred string for a cui" (ensure-cui-integer cui) (or (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-lrl-cui (cui &key (srl *current-srl*)) "Find LRL for a cui" (ensure-cui-integer cui) (collect-umlisp-query (mrconso (kcuilrl) srl cui cui :distinct t :single t) (ensure-integer kcuilrl))) (defun find-ucon-lui (lui &key (srl *current-srl*)) "Find list of ucon for lui" (ensure-lui-integer lui) (unless lui (return-from find-ucon-lui nil)) (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" (ensure-sui-integer sui) (collect-umlisp-query (mrconso (cui kcuilrl) srl sui sui :distinct t) (make-instance 'ucon :cui (ensure-integer cui) :pfstr (find-pfstr-cui cui) :lrl (ensure-integer kcuilrl)))) (defun find-ucon-aui (aui &key (srl *current-srl*)) "Find list of ucon for aui" (ensure-aui-integer aui) (collect-umlisp-query (mrconso (cui kcuilrl) srl aui aui :distinct t) (make-instance 'ucon :cui (ensure-integer cui) :pfstr (find-pfstr-cui cui) :lrl (ensure-integer kcuilrl)))) (defun find-ucon-cuisui (cui sui &key (srl *current-srl*)) "Find ucon for cui/sui" (ensure-cui-integer cui) (ensure-sui-integer sui) (when (and cui sui) (collect-umlisp-query (mrconso (kcuilrl) srl kcuisui (make-cuisui cui sui)) (make-instance 'ucon :cui cui :pfstr (find-pfstr-cui cui) :lrl (ensure-integer kcuilrl))))) (defun find-ucon-str (str &key (srl *current-srl*)) "Find ucon that are exact match for str" (collect-umlisp-query (mrconso (cui kcuilrl) srl str str :distinct t) (make-instance 'ucon :cui (ensure-integer cui) :pfstr (find-pfstr-cui cui) :lrl (ensure-integer kcuilrl)))) (defun find-ucon-all (&key (srl *current-srl*)) "Return list of all ucon's" (with-sql-connection (db) (clsql:map-query 'list #'(lambda (tuple) (destructuring-bind (cui cuilrl) tuple (make-instance 'ucon :cui (ensure-integer cui) :pfstr (find-pfstr-cui cui) :lrl (ensure-integer cuilrl)))) (query-string mrconso (cui kcuilrl) srl nil nil :order (cui asc) :distinct t) :database db))) (defun find-ucon-all2 (&key (srl *current-srl*)) "Return list of all ucon's" (collect-umlisp-query (mrconso (cui kcuilrl) srl nil nil :order (cui asc) :distinct t) (make-instance 'ucon :cui (ensure-integer cui) :pfstr (find-pfstr-cui cui) :lrl (ensure-integer kcuilrl)))) (defun find-cui-ucon-all (&key (srl *current-srl*)) "Return list of CUIs for all ucons" (collect-umlisp-query (mrconso (cui) srl nil nil :order (cui asc) :distinct t) cui)) (defun map-ucon-all (fn &key (srl *current-srl*)) "Map a function over all ucon's" (with-sql-connection (db) (clsql:map-query nil #'(lambda (tuple) (destructuring-bind (cui cuilrl) tuple (funcall fn (make-instance 'ucon :cui (ensure-integer cui) :pfstr (find-pfstr-cui cui) :lrl (ensure-integer cuilrl))))) (query-string mrconso (cui kcuilrl) srl nil nil :order (cui asc) :distinct t) :database db))) (defun find-udef-cui (cui &key (srl *current-srl*)) "Return a list of udefs for cui" (ensure-cui-integer cui) (collect-umlisp-query (mrdef (sab def suppress) srl cui cui :lrl "KSRL") (make-instance 'udef :sab sab :def def :suppress suppress))) (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 :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 :dockey dockey :dvalue value :dtype type :expl expl))) (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 :dockey dockey :dvalue value :dtype type :expl expl))) (defun find-usty-cui (cui &key (srl *current-srl*)) "Return a list of usty for cui" (ensure-cui-integer cui) (collect-umlisp-query (mrsty (tui sty) srl cui cui :lrl "KLRL") (make-instance 'usty :tui (ensure-integer tui) :sty sty))) (defun find-usty-word (word &key (srl *current-srl*)) "Return a list of usty that match word" (collect-umlisp-query (mrsty (tui sty) srl sty word :lrl klrl :like t :distinct t) (make-instance 'usty :tui (ensure-integer tui) :sty sty))) (defun find-urel-cui (cui &key (srl *current-srl*) filter without-pfstr2) "Return a list of urel for cui" (ensure-cui-integer cui) (collect-umlisp-query (mrrel (aui1 rel stype1 cui2 aui2 stype2 rela rui srui sab sl rg dir suppress cvf) srl cui1 cui :lrl "KSRL" :filter filter) (let ((rel (make-instance 'urel :cui1 cui :aui1 (ensure-integer aui1) :stype1 stype1 :rel rel :cui2 (ensure-integer cui2) :aui2 (ensure-integer aui2) :stype2 stype2 :rui (ensure-integer rui) :srui srui :rela rela :sab sab :sl sl :rg rg :dir dir :suppress suppress :cvf cvf))) (unless without-pfstr2 (setf (slot-value rel 'pfstr2) (find-pfstr-cui cui2))) rel))) (defun find-urel-rui (rui &key (srl *current-srl*)) "Return the urel for a rui" (ensure-rui-integer rui) (collect-umlisp-query (mrrel (aui1 rel stype1 cui1 cui2 aui2 stype2 rela rui srui sab sl rg dir suppress cvf) srl rui rui :lrl "KSRL" :single t) (make-instance 'urel :cui1 cui1 :aui1 (ensure-integer aui1) :stype1 stype1 :rel rel :cui2 (ensure-integer cui2) :aui2 (ensure-integer aui2) :stype2 stype2 :rui (ensure-integer rui) :srui srui :rela rela :sab sab :sl sl :rg rg :dir dir :suppress suppress :cvf cvf :pfstr2 (find-pfstr-cui cui2)))) (defun find-cui2-urel-cui (cui &key (srl *current-srl*)) "Return a list of urel for cui" (ensure-cui-integer cui) (collect-umlisp-query (mrrel (cui2) srl cui1 cui :lrl "KSRL") cui2)) (defun find-urel-cui2 (cui2 &key (srl *current-srl*)) "Return a list of urel for cui2" (ensure-cui-integer cui2) (collect-umlisp-query (mrrel (rel cui1 aui1 stype1 aui2 stype2 rela rui srui sab sl rg dir suppress cvf) srl cui2 cui2 :lrl "KSRL") (make-instance 'urel :cui2 cui2 :rel rel :aui2 (ensure-integer aui2) :stype2 stype2 :rui (ensure-integer rui) :srui srui :stype1 stype1 :cui1 (ensure-integer cui1) :aui1 (ensure-integer aui1) :rela rela :sab sab :sl sl :rg rg :dir dir :suppress suppress :cvf cvf :pfstr2 (find-pfstr-cui cui2)))) (defun find-ucon-rel-cui2 (cui2 &key (srl *current-srl*)) (ensure-cui-integer cui2) (loop for cui in (remove-duplicates (mapcar #'cui1 (find-urel-cui2 cui2 :srl srl))) collect (find-ucon-cui cui :srl srl))) (defun find-ucoc-cui (cui &key (srl *current-srl*)) "Return a list of ucoc for cui" (ensure-cui-integer cui) (collect-umlisp-query (mrcoc (aui1 cui2 aui2 sab cot cof coa) srl cui1 cui :lrl klrl :order (cof asc)) (setq cui2 (ensure-integer cui2)) (when (eql 0 cui2) (setq cui2 nil)) (make-instance 'ucoc :cui1 cui :aui1 (ensure-integer aui1) :cui2 (ensure-integer cui2) :aui2 (ensure-integer aui2) :cot cot :cof (ensure-integer cof) :coa coa :sab sab :pfstr2 (find-pfstr-cui cui2)))) (defun find-ucoc-cui2 (cui2 &key (srl *current-srl*)) "Return a list of ucoc for cui2" (ensure-cui-integer cui2) (collect-umlisp-query (mrcoc (cui1 aui1 aui2 sab cot cof coa) srl cui2 cui2 :lrl klrl :order (cof asc)) (when (zerop cui2) (setq cui2 nil)) (make-instance 'ucoc :cui1 (ensure-integer cui1) :cui2 cui2 :aui1 (ensure-integer aui1) :aui2 (ensure-integer aui2) :sab sab :cot cot :cof (ensure-integer cof) :coa coa :pfstr2 (find-pfstr-cui cui2)))) (defun find-ucon-coc-cui2 (cui2 &key (srl *current-srl*)) "List of ucon with co-occurance cui2" (ensure-cui-integer cui2) (mapcar #'(lambda (cui) (find-ucon-cui cui :srl srl)) (remove-duplicates (mapcar #'cui1 (find-ucoc-cui2 cui2 :srl srl))))) (defun find-uterm-cui (cui &key (srl *current-srl*)) "Return a list of uterm for cui" (ensure-cui-integer cui) (collect-umlisp-query (mrconso (lui lat ts kluilrl) srl cui cui :lrl kluilrl :distinct t) (make-instance 'uterm :lui (ensure-integer lui) :cui cui :lat lat :ts ts :lrl (ensure-integer kluilrl)))) (defun find-uterm-lui (lui &key (srl *current-srl*)) "Return a list of uterm for lui" (ensure-lui-integer lui) (collect-umlisp-query (mrconso (cui lat ts kluilrl) srl lui lui :lrl kluilrl :distinct t) (make-instance 'uterm :cui (ensure-integer cui) :lui lui :lat lat :ts ts :lrl (ensure-integer kluilrl)))) (defun find-uterm-cuilui (cui lui &key (srl *current-srl*)) "Return single uterm for cui/lui" (ensure-cui-integer cui) (ensure-lui-integer lui) (collect-umlisp-query (mrconso (lat ts kluilrl) srl kcuilui (make-cuilui cui lui) :lrl kluilrl :single t) (make-instance 'uterm :cui cui :lui lui :lat lat :ts ts :lrl (ensure-integer kluilrl)))) (defun find-ustr-cuilui (cui lui &key (srl *current-srl*)) "Return a list of ustr for cui/lui" (ensure-cui-integer cui) (ensure-lui-integer lui) (collect-umlisp-query (mrconso (sui stt str suppress ksuilrl) srl kcuilui (make-cuilui cui lui) :lrl ksuilrl) (make-instance 'ustr :sui (ensure-integer sui) :cui cui :lui lui :cuisui (make-cuisui cui sui) :stt stt :str str :suppress suppress :lrl (ensure-integer ksuilrl)))) (defun find-ustr-cuisui (cui sui &key (srl *current-srl*)) "Return the single ustr for cuisui" (ensure-cui-integer cui) (ensure-sui-integer sui) (collect-umlisp-query (mrconso (lui stt str suppress ksuilrl) srl kcuisui (make-cuisui cui sui) :lrl lsuilrl :single t) (make-instance 'ustr :sui sui :cui cui :cuisui (make-cuisui cui sui) :lui (ensure-integer lui) :stt stt :str str :suppress suppress :lrl (ensure-integer ksuilrl)))) (defun find-ustr-sui (sui &key (srl *current-srl*)) "Return the list of ustr for sui" (ensure-sui-integer sui) (collect-umlisp-query (mrconso (cui lui stt str suppress ksuilrl) srl sui sui :lrl ksuilrl) (make-instance 'ustr :sui sui :cui cui :stt stt :str str :cuisui (make-cuisui (ensure-integer cui) sui) :suppress suppress :lui (ensure-integer lui) :lrl (ensure-integer ksuilrl)))) (defun find-ustr-sab (sab &key (srl *current-srl*)) "Return the list of ustr for sab" (collect-umlisp-query (mrconso (kcuisui) srl sab sab :lrl srl) (let ((cuisui (ensure-integer kcuisui))) (apply #'find-ustr-cuisui (append (multiple-value-list (decompose-cuisui cuisui)) (list :srl srl)))))) (defun find-ustr-all (&key (srl *current-srl*)) "Return list of all ustr's" (with-sql-connection (db) (clsql:map-query 'list #'(lambda (tuple) (destructuring-bind (cui lui sui stt ksuilrl suppress) tuple (make-instance 'ustr :cui (ensure-integer cui) :lui (ensure-integer lui) :sui (ensure-integer sui) :stt stt :str (find-pfstr-cui cui) :cuisui (make-cuisui (ensure-integer cui) (ensure-integer sui)) :suppress suppress :lrl (ensure-integer ksuilrl)))) (query-string mrconso (cui lui sui stt ksuilrl) srl nil nil :lrl ksuilrl :distinct t :order (sui asc)) :database db))) (defun find-string-sui (sui &key (srl *current-srl*)) "Return the string associated with sui" (ensure-sui-integer sui) (collect-umlisp-query (mrconso (str) srl sui sui :lrl ksuilrl :single t) str)) (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 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 :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 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 :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 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 :lat lat :str str))) (defun find-uhier-cui (cui &key (srl *current-srl*)) (ensure-cui-integer cui) (collect-umlisp-query (mrhier (aui cxn paui sab rela ptr hcd cvf) srl cui cui :lrl ksrl) (make-instance 'uhier :cui cui :aui (ensure-integer aui) :cxn (ensure-integer cxn) :paui (ensure-integer paui) :sab sab :rela rela :ptr ptr :hcd hcd :cvf cvf))) (defun find-uhier-all (&key (srl *current-srl*)) (collect-umlisp-query (mrhier (cui aui cxn paui sab rela ptr hcd cvf) srl nil nil :lrl ksrl) (make-instance 'uhier :cui cui :aui (ensure-integer aui) :cxn (ensure-integer cxn) :paui (ensure-integer paui) :sab sab :rela rela :ptr ptr :hcd hcd :cvf cvf))) (defun find-usat-ui (cui &optional lui sui &key (srl *current-srl*)) (ensure-cui-integer cui) (ensure-lui-integer lui) (ensure-sui-integer sui) (let ((ls "SELECT CODE,ATN,SAB,ATV FROM MRSAT WHERE ")) (cond (sui (string-append ls "KCUISUI='" (integer-string (make-cuisui cui sui) 14) "'")) (lui (string-append ls "KCUILUI='" (integer-string (make-cuilui cui lui) 14) "' and sui='0'")) (t (string-append ls "cui='" (prefixed-fixnum-string cui nil 7) "' and lui='0' and sui='0'"))) (when srl (string-append ls " and KSRL<=" (prefixed-fixnum-string srl nil 3))) (loop for tuple in (mutex-sql-query ls) collect (destructuring-bind (code atn sab atv) tuple (make-instance 'usat :code code :atn atn :sab sab :atv atv))))) (defun find-usty-tui (tui) "Find usty for tui" (ensure-tui-integer tui) (collect-umlisp-query (mrsty (sty) nil tui tui :single t) (make-instance 'usty :tui tui :sty sty))) (defun find-usty-sty (sty) "Find usty for a sty" (collect-umlisp-query (mrsty (tui) nil sty sty :single t) (make-instance 'usty :tui (ensure-integer tui) :sty sty))) (defun find-usty-all () "Return list of usty's for all semantic types" (collect-umlisp-query (mrsty (tui) nil nil nil :distinct t) (find-usty-tui tui))) (defun find-usab-all () "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) (make-instance 'usab :vcui (ensure-integer vcui) :rcui (ensure-integer rcui) :vsab vsab :rsab rsab :son son :sf sf :sver sver :vstart vstart :vend vend :imeta imeta :rmeta rmeta :slc slc :scc scc :srl (ensure-integer srl) :tfr (ensure-integer tfr) :cfr (ensure-integer cfr) :cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc :curver curver :sabin sabin :ssn ssn :scit scit))) (defun find-usab-by-key (key-name key) "Find usab for a key" (collect-umlisp-query-eval ('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 key-name key :single t) (make-instance 'usab :vcui (ensure-integer vcui) :rcui (ensure-integer rcui) :vsab vsab :rsab rsab :son son :sf sf :sver sver :vstart vstart :vend vend :imeta imeta :rmeta rmeta :slc slc :scc scc :srl (ensure-integer srl) :tfr (ensure-integer tfr) :cfr (ensure-integer cfr) :cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc :curver curver :sabin sabin :ssn ssn :scit scit))) (defun find-usab-rsab (rsab) "Find usab for rsab" (find-usab-by-key 'rsab rsab)) (defun find-usab-vsab (vsab) "Find usab for vsab" (find-usab-by-key 'vsab vsab)) (defun find-cui-max () (ensure-integer (caar (mutex-sql-query "select max(CUI) from MRCON")))) (defun find-umap-cui (cui) (ensure-cui-integer cui) (collect-umlisp-query (mrmap (mapsetsab mapsubsetid maprank fromid fromsid fromexpr fromtype fromrule fromres rel rela toid tosid toexpr totype torule tores maprule maptype mapatn mapatv cvf) nil mapsetcui cui) (make-instance 'umap :mapsetcui cui :mapsetsab mapsetsab :mapsubsetid mapsubsetid :maprank (ensure-integer maprank) :fromid fromid :fromsid fromsid :fromexpr fromexpr :fromtype fromtype :fromrule fromrule :fromres fromres :rel rel :rela rela :toid toid :tosid tosid :toexpr toexpr :totype totype :torule torule :tores tores :maprule maprule :maptype maptype :mapatn mapatn :mapatv mapatv :cvf cvf))) (defun find-usmap-cui (cui) (ensure-cui-integer cui) (collect-umlisp-query (mrsmap (mapsetsab fromexpr fromtype rel rela toexpr totype cvf) nil mapsetcui cui) (make-instance 'usmap :mapsetcui cui :mapsetsab mapsetsab :fromexpr fromexpr :fromtype fromtype :rel rel :rela rela :toexpr toexpr :totype totype :cvf cvf))) ;;;; Cross table find functions (defun find-ucon-tui (tui &key (srl *current-srl*)) "Find list of ucon for tui" (ensure-tui-integer tui) (collect-umlisp-query (mrsty (cui) srl tui tui :lrl klrl :order (cui asc)) (find-ucon-cui (ensure-integer cui) :srl srl))) (defun mrconso-query-word-cui (word sab srl like) (format nil "SELECT DISTINCT c.cui FROM MRCONSO c,MRXW_ENG x WHERE x.WD~A'~A' AND x.cui=c.cui~A~A" (if like " LIKE " "=") (clsql-sys::sql-escape-quotes word) (etypecase sab (string (format nil " AND c.sab='~A'" (clsql-sys::sql-escape-quotes sab))) (cons (format nil " AND c.sab IN (~{'~A'~^,~})" (mapcar 'clsql-sys::sql-escape-quotes sab))) (null "")) (if srl (format nil " AND KCUILRL <= ~A" srl) ""))) (defun mrconso-query-word-sui (word sab srl like) (format nil "SELECT DISTINCT c.sui FROM MRCONSO c,MRXW_ENG x WHERE x.WD~A'~A' AND x.sui=c.sui~A~A" (if like " LIKE " "=") (clsql-sys::sql-escape-quotes word) (etypecase sab (string (format nil " AND c.sab='~A'" (clsql-sys::sql-escape-quotes sab))) (cons (format nil " AND c.sab IN (~{'~A'~^,~})" (mapcar 'clsql-sys::sql-escape-quotes sab))) (null "")) (if srl (format nil " AND KCUILRL <= ~A" srl) ""))) (defun find-uconso-word (word &key sab (srl *current-srl*) (like nil)) "Return list of uconso that match word. Optionally, matching SAB. Optionally, use SQL's LIKE syntax" (cond (sab (let ((sui-query (mrconso-query-word-sui word sab srl like)) (uconsos nil)) (dolist (sui (remove-duplicates (sort (mapcar 'car (mutex-sql-query sui-query)) #'<))) (setq uconsos (nconc uconsos (find-uconso-sui sui :sab sab)))) (remove-duplicates uconsos :key 'cui))) (t (collect-umlisp-query-eval ('mrxw_eng '(cui) srl 'wd word :like like :distinct t :lrl 'klrl :order '(cui asc)) (find-uconso-cui cui :srl srl))))) (defun find-ucon-word (word &key sab (srl *current-srl*) (like nil)) "Return list of ucon that match word in matching SAB. Optionally, use SQL's LIKE syntax" (cond (sab (let ((query (mrconso-query-word-cui word sab srl like))) (loop for tuple in (mutex-sql-query query) collect (make-instance 'ucon :cui (first tuple))))) (t (collect-umlisp-query-eval ('mrxw_eng '(cui) srl 'wd word :like like :distinct t :lrl 'klrl :order '(cui asc)) (find-ucon-cui cui :srl srl))))) (defun find-ucon-normalized-word (word &key (srl *current-srl*) (like nil)) "Return list of ucons that match word, optionally use SQL's LIKE syntax" (collect-umlisp-query-eval ('mrxnw_eng '(cui) srl 'nwd word :like like :distinct t :lrl 'klrl :order '(cui asc)) (find-ucon-cui cui :srl srl))) (defun find-cui-normalized-word (word &key (srl *current-srl*) (like nil)) "Return list of cui that match word, optionally use SQL's LIKE syntax" (collect-umlisp-query-eval ('mrxnw_eng '(cui) srl 'nwd word :like like :distinct t :lrl 'klrl :order '(cui asc)) cui)) (defun find-lui-normalized-word (word &key (srl *current-srl*) (like nil)) "Return list of cui that match word, optionally use SQL's LIKE syntax" (collect-umlisp-query-eval ('mrxnw_eng '(lui) srl 'nwd word :like like :distinct t :lrl 'klrl :order '(cui asc)) lui)) (defun find-sui-normalized-word (word &key (srl *current-srl*) (like nil)) "Return list of cui that match word, optionally use SQL's LIKE syntax" (collect-umlisp-query-eval ('mrxnw_eng '(sui) srl 'nwd word :like like :distinct t :lrl 'klrl :order '(cui asc)) sui)) (defun find-ustr-word (word &key sab (srl *current-srl*) (like nil)) "Return list of ustr that match word in matching SAB. Optionally, use SQL's LIKE syntax" (cond (sab (let ((query (format nil "SELECT c.sui,c.cui,c.lui,c.str,c.lrl,c.stt,c.suppress,c.cuisui FROM MRCONSO c,MRXW_ENG x WHERE x.WD ~A '~A' AND x.cui=c.cui AND x.lui=c.lui AND x.sui=c.sui~A~A" (if like "LIKE" "=") (clsql-sys::sql-escape-quotes word) (typecase sab (string (format nil " AND c.sab='~A'" (clsql-sys::sql-escape-quotes sab))) (cons (format nil " AND c.sab IN (~('~A'~^,~))" (mapcar 'clsql-sys::sql-escape-quotes sab))) (null "")) (if srl (format nil " AND KCUILRL <= ~D" srl) "")))) (loop for tuple in (mutex-sql-query query) collect (destructuring-bind (sui cui lui str lrl stt suppress cuisui) tuple (make-instance 'ustr :sui sui :cui cui :lui lui :str str :lrl lrl :stt stt :suppress suppress :cuisui cuisui))))) (t (collect-umlisp-query (mrxw_eng (cui sui) srl wd word :lrl klrl :order (cui asc sui asc)) (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl))))) (defun find-ustr-normalized-word (word &key (srl *current-srl*)) "Return list of ustrs that match word" (collect-umlisp-query (mrxnw_eng (cui sui) srl nwd word :lrl klrl :order (cui asc sui asc)) (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl))) (defun find-uterm-word (word &key (srl *current-srl*)) "Return list of uterms that match word" (collect-umlisp-query (mrxw_eng (cui lui) srl wd word :lrl klrl :order (cui asc lui asc)) (find-uterm-cuilui (ensure-integer cui) (ensure-integer lui) :srl srl))) (defun find-uterm-normalized-word (word &key (srl *current-srl*)) "Return list of uterms that match word" (collect-umlisp-query (mrxnw_eng (cui lui) srl nwd word :lrl klrl :order (cui asc lui asc)) (find-uterm-cuilui (ensure-integer cui) (ensure-integer lui) :srl srl))) (defun find-ucon-noneng-word (word &key (srl *current-srl*) (like nil)) "Return list of ucons that match non-english word" (collect-umlisp-query-eval ('mrxw_noneng '(cui) srl 'wd word :like like :distinct t :lrl 'klrl :order '(cui asc)) (find-ucon-cui cui :srl srl))) (defun find-ustr-noneng-word (word &key (srl *current-srl*)) "Return list of ustrs that match non-english word" (collect-umlisp-query (mrxw_noneng (cui sui) srl wd word :lrl klrl :order (cui asc sui asc)) (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl))) ;; Special tables (defun find-usrl-all () (collect-umlisp-query (usrl (sab srl) nil nil nil :order (sab asc)) (make-instance 'usrl :sab sab :srl (ensure-integer srl)))) ;;; Multiword lookup and score functions (defun find-uobj-multiword (str obj-lookup-fun sort-fun key srl only-exact-if-match limit &key extra-lookup-args) (let ((uobjs '())) (dolist (word (delimited-string-to-list str #\space)) (setq uobjs (append uobjs (apply obj-lookup-fun word :srl srl extra-lookup-args)))) (let ((sorted (funcall sort-fun str (delete-duplicates uobjs :test #'= :key key)))) (let ((len (length sorted))) (cond ((zerop len) (return-from find-uobj-multiword nil)) ((and only-exact-if-match (multiword-match str (pfstr (first sorted)))) (first sorted)) (limit (if (and (plusp limit) (> len limit)) (subseq sorted 0 limit) limit)) (t sorted)))))) (defun find-ucon-multiword (str &key (srl *current-srl*) (only-exact-if-match t) limit sab) (find-uobj-multiword str #'find-ucon-word #'sort-score-pfstr-str #'cui srl only-exact-if-match limit :extra-lookup-args (list :sab sab))) (defun find-uconso-multiword (str &key (srl *current-srl*) (only-exact-if-match t) limit sab) (find-uobj-multiword str #'find-uconso-word #'sort-score-pfstr-str #'cui srl only-exact-if-match limit :extra-lookup-args (list :sab sab))) (defun find-uterm-multiword (str &key (srl *current-srl*) (only-exact-if-match t) limit) (find-uobj-multiword str #'find-uterm-word #'sort-score-pfstr-str #'lui srl only-exact-if-match limit)) (defun find-ustr-multiword (str &key (srl *current-srl*) (only-exact-if-match t) limit sab) (find-uobj-multiword str #'find-ustr-word #'sort-score-ustr-str #'sui srl only-exact-if-match limit :extra-lookup-args (list :sab sab))) (defun sort-score-pfstr-str (str uobjs) "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr" (sort-score-umlsclass-str uobjs str #'pfstr)) (defun sort-score-ustr-str (str ustrs) "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr" (sort-score-umlsclass-str ustrs str #'str)) (defun sort-score-umlsclass-str (objs str lookup-func) "Sort a list of objects based on scoring to a string" (let ((scored '())) (dolist (obj objs) (push (list obj (score-multiword-match str (funcall lookup-func obj))) scored)) (mapcar #'car (sort scored #'> :key #'cadr)))) ;;; LEX SQL functions (defun find-lexterm-eui (eui) (ensure-eui-integer eui) (collect-umlisp-query (lrwd (wrd) nil eui eui :single t) (make-instance 'lexterm :eui eui :wrd wrd))) (defun find-lexterm-word (wrd) (collect-umlisp-query (lrwd (eui) nil wrd wrd) (make-instance 'lexterm :eui (ensure-integer eui) :wrd (copy-seq wrd)))) ;; LEX SQL Read functions (defun find-labr-eui (eui) (ensure-eui-integer eui) (collect-umlisp-query (lrabr (bas abr eui2 bas2) nil eui eui) (make-instance 'labr :eui eui :bas bas :abr abr :bas2 bas2 :eui2 (ensure-integer eui2)))) (defun find-labr-bas (bas) (collect-umlisp-query (labr (eui abr eui2 bas2) nil bas bas) (make-instance 'labr :eui (ensure-integer eui) :abr abr :bas2 bas2 :bas (copy-seq bas) :eui2 (ensure-integer eui2)))) (defun find-lagr-eui (eui) (ensure-eui-integer eui) (collect-umlisp-query (lragr (str sca agr cit bas) nil eui eui) (make-instance 'lagr :eui eui :str str :sca sca :agr agr :cit cit :bas bas))) (defun find-lcmp-eui (eui) (ensure-eui-integer eui) (collect-umlisp-query (lrcmp (bas sca com) nil eui eui) (make-instance 'lcmp :eui eui :bas bas :sca sca :com com))) (defun find-lmod-eui (eui) (ensure-eui-integer eui) (collect-umlisp-query (lrmod (bas sca psn_mod fea) nil eui eui) (make-instance 'lmod :eui eui :bas bas :sca sca :psnmod psn_mod :fea fea))) (defun find-lnom-eui (eui) (ensure-eui-integer eui) (collect-umlisp-query (lrnom (bas sca eui2 bas2 sca2) nil eui eui) (make-instance 'lnom :eui eui :bas bas :sca sca :bas2 bas2 :sca2 sca2 :eui2 (ensure-integer eui2)))) (defun find-lprn-eui (eui) (ensure-eui-integer eui) (collect-umlisp-query (lrprn (bas num gnd cas pos qnt fea) nil eui eui) (make-instance 'lprn :eui eui :bas bas :num num :gnd gnd :cas cas :pos pos :qnt qnt :fea fea))) (defun find-lprp-eui (eui) (ensure-eui-integer eui) (collect-umlisp-query (lrprp (bas str sca fea) nil eui eui) (make-instance 'lprp :eui eui :bas bas :str str :sca sca :fea fea))) (defun find-lspl-eui (eui) (ensure-eui-integer eui) (collect-umlisp-query (lrspl (spv bas) nil eui eui) (make-instance 'lspl :eui eui :spv spv :bas bas))) (defun find-ltrm-eui (eui) (ensure-eui-integer eui) (collect-umlisp-query (lrtrm (bas gen) nil eui eui) (make-instance 'ltrm :eui eui :bas bas :gen gen))) (defun find-ltyp-eui (eui) (ensure-eui-integer eui) (collect-umlisp-query (lrtyp (bas sca typ) nil eui eui) (make-instance 'ltyp :eui eui :bas bas :sca sca :typ typ))) (defun find-lwd-wrd (wrd) (make-instance 'lwd :wrd wrd :euilist (collect-umlisp-query (lrwd (eui) nil wrd wrd) (ensure-integer eui)))) ;;; Semantic Network SQL access functions (defun find-sdef-ui (ui) (collect-umlisp-query (srdef (rt sty_rl stn_rtn def ex un rh abr rin) nil ui ui :single t) (make-instance 'sdef :rt rt :ui ui :styrl sty_rl :stnrtn stn_rtn :def def :ex ex :un un :rh rh :abr abr :rin rin))) (defun find-sstre1-ui (ui) (collect-umlisp-query (srstre1 (ui2 ui3) nil ui ui) (make-instance 'sstre1 :ui ui :ui2 (ensure-integer ui2) :ui3 (ensure-integer ui3)))) (defun find-sstre1-ui2 (ui2) (collect-umlisp-query (srstre1 (ui ui3) nil ui2 ui2) (make-instance 'sstre1 :ui (ensure-integer ui) :ui2 ui2 :ui3 (ensure-integer ui3)))) (defun find-sstr-rl (rl) (collect-umlisp-query (srstre (sty_rl sty_rl2 ls) nil rl rl) (make-instance 'sstr :rl rl :styrl sty_rl :styrl2 sty_rl2 :ls ls))) (defun find-sstre2-sty (sty) (collect-umlisp-query (srstre2 (rl sty2) nil sty sty) (make-instance 'sstre2 :sty (copy-seq sty) :rl rl :sty2 sty2))) (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) (ignore-errors (sql-execute "drop table USTATS" conn)) (sql-execute "create table USTATS (NAME varchar(160), COUNT bigint, SRL integer)" conn) (dotimes (srl 5) (insert-ustats-count conn "Concept Count" "MRCONSO" "distinct CUI" "KCUILRL" srl) (insert-ustats-count conn "Term Count" "MRCONSO" "distinct KCUILUI" "KCUILRL" srl) (insert-ustats-count conn "Distinct Term Count" "MRCONSO" "distinct LUI" "KLUILRL" srl) (insert-ustats-count conn "String Count" "MRCONSO" "*" "KSUILRL" srl) (insert-ustats-count conn "Distinct String Count" "MRCONSO" "distinct SUI" "KSUILRL" srl) (insert-ustats-count conn "Hierarchcy" "MRHIER" "*" "KSRL" srl) (insert-ustats-count conn "Mappings" "MRMAP" "*" "KSRL" srl) (insert-ustats-count conn "Simple Mappings" "MRSMAP" "*" "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 "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 Abbreviation Count" "MRSAB" "*" "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)) (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*)) (if 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))) (collect-umlisp-query (ustats (name count srl) nil nil nil :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)))) cl-umlisp-2007ac.2/sql.lisp0000644000175000017500000000642410667175521014537 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: sql.lisp ;;;; Purpose: Low-level SQL routines data for UMLisp ;;;; Author: Kevin M. Rosenberg ;;;; Created: Apr 2000 ;;;; ;;;; $Id$ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2006 by Kevin M. Rosenberg, M.D. ;;;; ;;;; UMLisp users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU General Public License. ;;;; ************************************************************************* (in-package #:umlisp) (defvar +umls-sql-map+ '((:2004aa . "KUMLS2004AA") (:2006ac . "KUMLS2006AC") (:2006ad . "MTS2006AD"))) (defvar +default-umls-db+ "MTS2006AD") (defun lookup-db-name (db) (cdr (assoc (ensure-keyword db) +umls-sql-map+))) (defvar *umls-sql-db* +default-umls-db+) (defun umls-sql-db () *umls-sql-db*) (defun umls-sql-db! (db) (etypecase db (string (setq *umls-sql-db* db)) (keyword (setq *umls-sql-db* (lookup-db-name db))))) (defvar *umls-sql-user* "secret") (defun umls-sql-user () *umls-sql-user*) (defun umls-sql-user! (u) (sql-disconnect-pooled) (setq *umls-sql-user* u)) (defvar *umls-sql-passwd* "secret") (defun umls-sql-passwd () *umls-sql-passwd*) (defun umls-sql-passwd! (p) (sql-disconnect-pooled) (setq *umls-sql-passwd* p)) (defvar *umls-sql-host* "localhost") (defun umls-sql-host () *umls-sql-host*) (defun umls-sql-host! (h) (sql-disconnect-pooled) (setq *umls-sql-host* h)) (defvar *umls-sql-type* :mysql) (defun umls-sql-type () *umls-sql-type*) (defun umls-sql-type! (h) (sql-disconnect-pooled) (setq *umls-sql-type* h)) (defun umls-connection-spec () (list *umls-sql-host* *umls-sql-db* *umls-sql-user* *umls-sql-passwd*)) (defun sql-connect () "Connect to UMLS database, automatically used pooled connections" (clsql:connect (umls-connection-spec) :database-type *umls-sql-type* :pool t)) (defun sql-disconnect (conn) "Disconnect from UMLS database, but put connection back into pool" (clsql:disconnect :database conn)) (defun sql-disconnect-pooled () (clsql:disconnect-pooled)) (defmacro with-sql-connection ((conn) &body body) `(let ((,conn (sql-connect))) (unwind-protect (progn ,@body) (when ,conn (clsql:disconnect :database ,conn))))) (defun sql-query (cmd conn &key (result-types :auto)) (clsql:query cmd :database conn :result-types result-types :field-names nil)) (defun sql-execute (cmd conn) (clsql:execute-command cmd :database conn)) (defun sql (stmt conn) (if (string-equal "SELECT" (subseq stmt 0 6)) (sql-query stmt conn) (sql-execute stmt conn))) (defun umls-sql (stmt) (check-type stmt string) (with-sql-connection (conn) (sql stmt conn))) ;;; Pool of open connections (defmacro with-mutex-sql ((conn) &body body) `(let ((,conn (sql-connect))) (unwind-protect (progn ,@body) (when ,conn (sql-disconnect ,conn))))) (defun mutex-sql-execute (cmd) (with-mutex-sql (conn) (sql-execute cmd conn))) (defun mutex-sql-query (cmd &key (result-types :auto)) (with-mutex-sql (conn) (sql-query cmd conn :result-types result-types))) cl-umlisp-2007ac.2/tests/0000755000175000017500000000000010754643523014202 5ustar kevinkevincl-umlisp-2007ac.2/tests/basic.lisp0000644000175000017500000000765410667175521016171 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: basic.lisp ;;;; Purpose: Basic tests for UMLisp ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: May 2003 ;;;; ;;;; $Id$ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. ;;;; ;;;; UMLisp users are granted the rights to distribute AND use this software ;;;; as governed by the terms of the GNU General Public License. ;;;; ************************************************************************* (in-package #:umlisp-tests) (setq *rt-basic* '( (deftest :qrystr/1 (umlisp::query-string mrconso (cui lui) nil nil nil) "SELECT CUI,LUI FROM MRCONSO") (deftest :qrystr/1e (umlisp::query-string-eval 'mrconso '(cui lui) nil nil nil) "SELECT CUI,LUI FROM MRCONSO") (deftest :qrystr/2 (umlisp::query-string mrconso (cui lui) 0 nil nil) "SELECT CUI,LUI FROM MRCONSO AND KCUILRL<=0") (deftest :qrystr/2e (umlisp::query-string-eval 'mrconso '(cui lui) 0 nil nil) "SELECT CUI,LUI FROM MRCONSO AND KCUILRL<=0") (deftest :qrystr/3 (umlisp::query-string mrconso (cui lui) nil cui 5) "SELECT CUI,LUI FROM MRCONSO WHERE CUI='5'") (deftest :qrystr/3e (umlisp::query-string-eval 'mrconso '(cui lui) nil 'cui 5) "SELECT CUI,LUI FROM MRCONSO WHERE CUI='5'") (deftest :qrystr/4 (umlisp::query-string mrconso (cui lui) nil kpfstr "Abc") "SELECT CUI,LUI FROM MRCONSO WHERE KPFSTR='Abc'") (deftest :qrystr/4e (umlisp::query-string-eval 'mrconso '(cui lui) nil 'kpfstr "Abc") "SELECT CUI,LUI FROM MRCONSO WHERE KPFSTR='Abc'") (deftest :qrystr/5 (umlisp::query-string mrconso (cui lui) 2 cui 5 :single t) "SELECT CUI,LUI FROM MRCONSO WHERE CUI='5' AND KCUILRL<=2 LIMIT 1") (deftest :qrystr/5e (umlisp::query-string-eval 'mrconso '(cui lui) 2 'cui 5 :single t) "SELECT CUI,LUI FROM MRCONSO WHERE CUI='5' AND KCUILRL<=2 LIMIT 1") (deftest :qrystr/6 (umlisp::query-string mrdef (sab def) 2 cui 39 :lrl ksrl :single t) "SELECT SAB,DEF FROM MRDEF WHERE CUI='39' AND KSRL<=2 LIMIT 1") (deftest :qrystr/6e (umlisp::query-string-eval 'mrdef '(sab def) 2 'cui 39 :lrl 'ksrl :single t) "SELECT SAB,DEF FROM MRDEF WHERE CUI='39' AND KSRL<=2 LIMIT 1") (deftest :qrystr/7 (umlisp::query-string mrdef (sab def) 2 cui 39 :lrl ksrl :order (cui asc)) "SELECT SAB,DEF FROM MRDEF WHERE CUI='39' AND KSRL<=2 ORDER BY CUI asc") (deftest :qrystr/7e (umlisp::query-string-eval 'mrdef '(sab def) 2 'cui 39 :lrl 'ksrl :order '(cui asc)) "SELECT SAB,DEF FROM MRDEF WHERE CUI='39' AND KSRL<=2 ORDER BY CUI asc") (deftest :qrystr/8 (umlisp::query-string mrdef (sab def) 2 cui 39 :lrl ksrl :order (cui asc def desc)) "SELECT SAB,DEF FROM MRDEF WHERE CUI='39' AND KSRL<=2 ORDER BY CUI asc,DEF desc") (deftest :qrystr/8e (umlisp::query-string-eval 'mrdef '(sab def) 2 'cui 39 :lrl 'ksrl :order '(cui asc def desc)) "SELECT SAB,DEF FROM MRDEF WHERE CUI='39' AND KSRL<=2 ORDER BY CUI asc,DEF desc") (deftest :ui/1 (umlisp::parse-cui "C0002341") 2341) (deftest :ui/2 (umlisp::parse-lui "L0002341") 2341) (deftest :ui/3 (umlisp::parse-sui "S0000000") 0) (deftest :ui/4 (umlisp::parse-tui "T123") 123) (deftest :ui/5 (fmt-cui 2341) "C0002341") (deftest :ui/6 (fmt-lui 2341) "L0002341") (deftest :ui/7 (fmt-sui 2341) "S0002341") (deftest :ui/8 (fmt-tui 231) "T231") (deftest :ui/9 (fmt-tui 231) "T231") (deftest :ui/10 (fmt-eui 231) "E0000231") (deftest :ui/11 (umlisp::make-cuisui 5 11) 50000011) (deftest :ui/12 (umlisp::decompose-cuisui 50000011) 5 11) (deftest :ui/13 (umlisp::parse-eui "E00002311") 2311) (deftest :ui/14 (umlisp::parse-lui "1234") 1234) (deftest :ui/15 (umlisp::parse-lui 1234) 1234) )) cl-umlisp-2007ac.2/tests/init.lisp0000644000175000017500000000221610667175521016040 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp-tests -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: basic.lisp ;;;; Purpose: Basic tests for UMLisp ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: May 2003 ;;;; ;;;; $Id$ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. ;;;; ;;;; UMLisp users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU General Public License. ;;;; ************************************************************************* (in-package #:umlisp-tests) (defvar *rt-basic* nil) (defvar *rt-parse* nil) (defvar *error-count* 0) (defvar *report-stream* *standard-output*) (setq regression-test::*catch-errors* nil) (defun run-tests () (regression-test:rem-all-tests) (dolist (test-form (append *rt-basic* *rt-parse*)) (eval test-form)) (let ((remaining (regression-test:do-tests *report-stream*))) (when (regression-test:pending-tests) (incf *error-count* (length remaining)))) *error-count*) cl-umlisp-2007ac.2/tests/package.lisp0000644000175000017500000000145610667175521016475 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: package.lisp ;;;; Purpose: Package definition for UMLisp Regression suite ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: May 2003 ;;;; ;;;; $Id$ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. ;;;; ;;;; UMLisp users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU General Public License. ;;;; ************************************************************************* (in-package #:cl-user) (defpackage #:umlisp-tests (:use #:umlisp #:cl #:rtest #:kmrcl) (:export #:run-tests)) cl-umlisp-2007ac.2/tests/parse.lisp0000644000175000017500000000470710667175521016216 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: parse.lisp ;;;; Purpose: Parsing tests for UMLisp ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: May 2003 ;;;; ;;;; $Id$ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. ;;;; ;;;; UMLisp users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU General Public License. ;;;; ************************************************************************* (in-package #:umlisp-tests) (eval-when (:compile-toplevel :load-toplevel :execute) (import '(umlisp::*umls-files* umlisp::*umls-cols*))) (setq *rt-parse* '( (deftest :parse/1 (umlisp::decompose-fil "abc") "abc" nil) (deftest :parse/2 (umlisp::decompose-fil "dir/abc") "abc" "dir") (deftest :parse/3 (umlisp::decompose-fil nil) nil nil) (deftest :parse/4 (umlisp::filename-to-tablename "test") "test") (deftest :parse/5 (umlisp::filename-to-tablename "TEST.AB.RRF") "TEST_AB"))) ;; specific for UMLS2007AA (when (probe-file (umlisp::umls-pathname "MRFILES.RRF")) (umlisp::ensure-ucols+ufiles) (setq *rt-parse* (append *rt-parse* '( (deftest uparse.1 (length *umls-files*) 63) (deftest uparse.2 (length *umls-cols*) 452) (deftest uparse.3 (sort (mapcar #'u::col (umlisp::ucols (umlisp::find-ufile "MRCONSO.RRF"))) #'string<) ("AUI" "CODE" "CUI" "CVF" "ISPREF" "KCUILRL" "KCUILUI" "KCUISUI" "KLUILRL" "KPFENG" "KSUILRL" "LAT" "LUI" "SAB" "SAUI" "SCUI" "SDUI" "SRL" "STR" "STT" "SUI" "SUPPRESS" "TS" "TTY")) (deftest uparse.4 (equal (sort (mapcar #'u::col (umlisp::ucols (umlisp::find-ufile "MRCONSO.RRF"))) #'string<) (sort (copy-seq (umlisp::fields (umlisp::find-ufile "MRCONSO.RRF"))) #'string<)) t) (deftest uparse.5 (sort (umlisp::custom-colnames-for-filename "MRCONSO.RRF") #'string<) ("KCUILRL" "KCUILUI" "KCUISUI" "KLUILRL" "KPFENG" "KSUILRL")) (deftest uparse.6 (compiled-function-p (umlisp::custom-value-fun (umlisp::find-ucol "KCUISUI" "MRCONSO.RRF"))) t) )))) cl-umlisp-2007ac.2/umlisp-tests.asd0000644000175000017500000000167410667175521016213 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: umlisp-tests.asd ;;;; Purpose: ASDF system definitionf for umlisp testing package ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: Apr 2003 ;;;; ;;;; $Id$ ;;;; ************************************************************************* (defpackage #:umlisp-tests-system (:use #:asdf #:cl)) (in-package #:umlisp-tests-system) (defsystem umlisp-tests :depends-on (:rt :umlisp) :components ((:module tests :serial t :components ((:file "package") (:file "init") (:file "basic") (:file "parse"))))) (defmethod perform ((o test-op) (c (eql (find-system 'umlisp-tests)))) (or (funcall (intern (symbol-name '#:run-tests) (find-package '#:umlisp-tests))) (error "test-op failed"))) cl-umlisp-2007ac.2/umlisp.asd0000644000175000017500000000377610667175521015060 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: umlisp.asd ;;;; Purpose: ASDF system definition file for UMLisp ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; ;;;; $Id$ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2006 by Kevin M. Rosenberg, M.D. ;;;; ;;;; UMLisp users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU General Public License. ;;;; ************************************************************************* (defpackage #:umlisp-system (:use #:asdf #:cl)) (in-package #:umlisp-system) (defsystem umlisp :components ((:file "package") (:file "data-structures" :depends-on ("package")) (:file "utils" :depends-on ("data-structures")) (:file "sql" :depends-on ("utils")) (:file "parse-macros" :depends-on ("sql")) (:file "parse-rrf" :depends-on ("parse-macros")) (:file "parse-common" :depends-on ("parse-rrf")) (:file "create-sql" :depends-on ("parse-common")) (:file "sql-classes" :depends-on ("sql")) (:file "classes" :depends-on ("sql-classes")) (:file "class-support" :depends-on ("classes")) (:file "composite" :depends-on ("sql-classes"))) :depends-on (clsql clsql-mysql kmrcl hyperobject)) (defmethod perform ((o test-op) (c (eql (find-system 'umlisp)))) (operate 'load-op 'umlisp-tests) (operate 'test-op 'umlisp-tests :force t)) (defmethod perform :after ((o load-op) (c (eql (find-system 'umlisp)))) (let ((init-file (or (probe-file (merge-pathnames (make-pathname :name ".umlisprc") (user-homedir-pathname))) #+(or mswin windows win32) (probe-file "c:\\etc\\umlisp-init.lisp")))) (when init-file (format t "loading umlisp init file ~A~%" init-file) (load init-file)))) cl-umlisp-2007ac.2/utils.lisp0000644000175000017500000001072310667175521015075 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: utils.lisp ;;;; Purpose: Low-level utility functions for UMLisp ;;;; Author: Kevin M. Rosenberg ;;;; Created: Apr 2000 ;;;; ;;;; $Id$ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2006 by Kevin M. Rosenberg, M.D. ;;;; ;;;; UMLisp users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU General Public License. ;;;; ************************************************************************* (in-package #:umlisp) (declaim (inline make-cuisui make-cuilui parse-ui parse-cui)) (defmacro def-metaclass-reader (field) "Create function for reading slot of metaclass" `(defun ,field (cl) (car (slot-value (class-of cl) ',field)))) (defmacro def-metaclass-reader-car (field) "Create function for reading slot of metaclass" `(defun ,field (cl) (car (slot-value (class-of cl) ',field)))) ;;; Field transformations (defun parse-ui (s &optional (nullvalue 0)) "Return integer value for a UMLS unique identifier." (declare (simple-string s) (optimize (speed 3) (safety 0))) (if (< (length s) 2) nullvalue (nth-value 0 (parse-integer s :start 1)))) (defun parse-cui (cui) (declare (optimize (speed 3) (safety 0))) (if (stringp cui) (let ((ch (schar cui 0))) (if (char-equal ch #\C) (parse-ui cui) (nth-value 0 (parse-integer cui)))) cui)) (defun parse-lui (lui) (declare (optimize (speed 3) (safety 0))) (if (stringp lui) (let ((ch (schar lui 0))) (if (char-equal ch #\L) (parse-ui lui) (nth-value 0 (parse-integer lui)))) lui)) (defun parse-sui (sui) (declare (optimize (speed 3) (safety 0))) (if (stringp sui) (let ((ch (schar sui 0))) (if (char-equal ch #\S) (parse-ui sui) (nth-value 0 (parse-integer sui)))) sui)) (defun parse-tui (tui) (declare (optimize (speed 3) (safety 0))) (if (stringp tui) (let ((ch (schar tui 0))) (if (char-equal ch #\T) (parse-ui tui) (nth-value 0 (parse-integer tui)))) tui)) (defun parse-aui (aui) (declare (optimize (speed 3) (safety 0))) (if (stringp aui) (let ((ch (schar aui 0))) (if (char-equal ch #\A) (parse-ui aui) (nth-value 0 (parse-integer aui)))) aui)) (defun parse-rui (rui) (declare (optimize (speed 3) (safety 0))) (if (stringp rui) (let ((ch (schar rui 0))) (if (char-equal ch #\R) (parse-ui rui) (nth-value 0 (parse-integer rui)))) rui)) (defun parse-eui (eui) (declare (optimize (speed 3) (safety 0))) (if (stringp eui) (let ((ch (schar eui 0))) (if (char-equal ch #\E) (parse-ui eui) (nth-value 0 (parse-integer eui)))) eui)) (defconstant +cuisui-scale+ 10000000) (declaim (type (integer 0 10000000) +cuisui-scale+)) #+(or 64bit x86-64) (defun make-cuisui (cui sui) (declare (type (integer 0 10000000) cui sui) (optimize (speed 3) (safety 0) (space 0))) (the fixnum (+ (the fixnum (* +cuisui-scale+ cui)) sui))) #-(or 64bit x86-64) (defun make-cuisui (cui sui) (when (and cui sui) (locally (declare (fixnum cui sui) (optimize (speed 3) (safety 0) (space 0))) (+ (* +cuisui-scale+ cui) sui)))) #+(or 64bit x86-64) (defun make-cuilui (cui lui) (declare (type (integer 0 10000000) cui lui) (optimize (speed 3) (safety 0) (space 0))) (the fixnum (+ (the fixnum (* +cuisui-scale+ cui)) lui))) #-(or 64bit x86-64) (defun make-cuilui (cui lui) (declare (fixnum cui lui) (optimize (speed 3) (safety 0) (space 0))) (+ (* +cuisui-scale+ cui) lui)) (defun decompose-cuisui (cuisui) "Returns the CUI and SUI of a cuisui number" #-(or 64bit x86-64) (declare (integer cuisui)) #+(or 64bit x86-64) (declare (fixnum cuisui)) (floor cuisui +cuisui-scale+)) ;;; Lookup functions for uterms,ustr in ucons (defun find-uterm-in-ucon (ucon lui) (find lui (s#term ucon) :key #'lui :test 'equal)) (defun find-ustr-in-uterm (uterm sui) (find sui (s#str uterm) :key #'sui :test 'equal)) (defun find-ustr-in-ucon (ucon sui) (dolist (uterm (s#term ucon)) (dolist (ustr (s#str uterm)) (when (string-equal sui (sui ustr)) (return-from find-ustr-in-ucon ustr))))) cl-umlisp-2007ac.2/create-sql.lisp0000644000175000017500000004163410754636052016000 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: sql-create ;;;; Purpose: Create SQL database for UMLisp ;;;; Author: Kevin M. Rosenberg ;;;; Created: Apr 2000 ;;;; ;;;; $Id$ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2006 by Kevin M. Rosenberg, M.D. ;;;; ;;;; UMLisp users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU General Public License. ;;;; ************************************************************************* (in-package #:umlisp) (defun create-table-cmd (file) "Return sql command to create a table" (let ((col-func (lambda (c) (let ((sqltype (sqltype c))) (case *umls-sql-type* (:oracle (cond ((string-equal sqltype "VARCHAR") (setq sqltype "VARCHAR2")) ((string-equal sqltype "BIGINT") (setq sqltype "VARCHAR2(20)"))))) (concatenate 'string (col c) " " (if (or (string-equal sqltype "VARCHAR") (string-equal sqltype "CHAR")) (format nil "~a (~a)" sqltype (cmax c)) sqltype)))))) (format nil "CREATE TABLE ~a (~{~a~^,~})~A~A" (table file) (mapcar col-func (ucols file)) (if (and (eq *umls-sql-type* :mysql) (string-equal (table file) "MRCXT")) " MAX_ROWS=200000000" "") (if (eq *umls-sql-type* :mysql) " TYPE=MYISAM CHARACTER SET utf8" "")))) (defun create-custom-table-cmd (tablename sql-cmd) "Return SQL command to create a custom table" (format nil "CREATE TABLE ~a AS ~a;" tablename sql-cmd)) (defun insert-col-value (col value) (if (null (parse-fun col)) value (format nil "~A" (funcall (parse-fun col) value)))) (defun insert-values-cmd (file values) "Return sql insert command for a row of values" (let ((insert-func (lambda (col value) (concatenate 'string (quote-str col) (insert-col-value col value) (quote-str col))))) (format nil "INSERT INTO ~a (~{~a~^,~}) VALUES (~A)" (table file) (fields file) (concat-separated-strings "," (mapcar insert-func (remove-custom-cols (ucols file)) values) (custom-col-values (custom-ucols-for-file file) values t))))) (defun custom-col-value (col values doquote) (let ((custom-value (funcall (custom-value-fun col) values))) (if custom-value (if doquote (concatenate 'string (quote-str col) (escape-backslashes custom-value) (quote-str col)) (escape-backslashes custom-value)) ""))) (defun custom-col-values (ucols values doquote) "Returns a list of string column values for SQL inserts for custom columns" (loop for col in ucols collect (custom-col-value col values doquote))) (defun remove-custom-cols (cols) "Remove custom cols from a list col umls-cols" (remove-if #'custom-value-fun cols)) (defun find-custom-cols-for-filename (filename) (remove-if-not (lambda (x) (string-equal filename (car x))) +custom-cols+)) (defun find-custom-col (filename col) (find-if (lambda (x) (and (string-equal filename (car x)) (string-equal col (cadr x)))) +custom-cols+)) (defun custom-colnames-for-filename (filename) (mapcar #'cadr (find-custom-cols-for-filename filename))) (defun custom-ucols-for-file (file) (remove-if-not #'custom-value-fun (ucols file))) (defun noneng-lang-index-files () (remove-if-not (lambda (f) (and (> (length (fil f)) 4) (string-equal (fil f) "MRXW_" :end1 5) (not (string-equal (fil f) "MRXW_ENG.RRF")) (not (string-equal (fil f) "MRXW_NONENG.RRF")))) *umls-files*)) ;;; SQL Command Functions (defun create-index-cmd (colname tablename length) "Return sql create index command" (format nil "CREATE INDEX ~a ON ~a (~a)" (concatenate 'string tablename "_" colname "_X") tablename (case *umls-sql-type* (:mysql (concatenate 'string colname (if (integerp length) (format nil " (~d)" length) ""))) ((:postgresql :postgresql-socket) ;; FIXME: incorrect syntax for postgresql? (if (integerp length) (format nil "substr((~A)::text,1,~D)" colname length) colname)) (t colname)))) (defun create-all-tables-cmdfile () "Return sql commands to create all tables. Not need for automated SQL import" (mapcar (lambda (f) (format nil "~a~%~%" (create-table-cmd f))) *umls-files*)) ;; SQL Execution functions (defun sql-drop-tables (conn) "SQL Databases: drop all tables" (dolist (file *umls-files*) (ignore-errors (sql-execute (format nil "DROP TABLE ~a" (table file)) conn)))) (defun sql-create-tables (conn) "SQL Databases: create all tables" (dolist (file *umls-files*) (sql-execute (create-table-cmd file) conn))) #+ignore (defun sql-create-kcon-table (conn) "Create concept table, one row per concept." (ignore-errors (execute-command "DROP TABLE KCON" :database conn)) (execute-command (format nil "CREATE TABLE KCON (CUI INTEGER, STR ~A, LRL ~A)" (case *umls-sql-type* (:oracle (format nil "VARCHAR2(~D)" (slot-value (find-ucol "STR" "MRCONSO.RRF") 'max))) (t "TEXT")) (case *umls-sql-type* (:mysql "TINYINT") ((:postgresql :postgresql-socket) "INT2") (:oracle "NUMBER(2,0)") (t "INTEGER"))) :database conn) ;; KCON deprecated by KPFENG field in MRCONSO #+nil (dolist (tuple (query "select distinct cui from MRCONSO order by cui" :database conn)) (let ((cui (car tuple))) (execute-command (format nil "INSERT into KCON VALUES (~D,'~A',~D)" cui (add-sql-quotes (pfstr-hash cui) ) (cui-lrl cui)) :database conn)))) (defun sql-create-custom-tables (conn) "SQL Databases: create all custom tables" ;;(sql-create-kcon-table conn) (dolist (ct +custom-tables+) (sql-execute (create-custom-table-cmd (car ct) (cadr ct)) conn))) (defun sql-insert-values (conn file) "SQL Databases: inserts all values for a file" (with-umls-file (line (fil file)) (sql-execute (insert-values-cmd file line) conn))) (defun sql-insert-all-values (conn) "SQL Databases: inserts all values for all files" (dolist (file *umls-files*) (sql-insert-values conn file))) (defun drop-index-cmd (colname tablename) "Return sql create index command" (case *umls-sql-type* (:mysql (format nil "DROP INDEX ~a ON ~a" (concatenate 'string tablename "_" colname "_X") tablename)) (t (format nil "DROP INDEX ~a" (concatenate 'string tablename "_" colname "_X"))))) (defun sql-create-indexes (conn &key (indexes +index-cols+) verbose) "SQL Databases: create all indexes" (dolist (idx indexes) (when verbose (format t "UMLS Import: Creating index for column ~A on table ~A.~%" (first idx) (second idx))) (ignore-errors (sql-execute (drop-index-cmd (car idx) (cadr idx)) conn)) (sql-execute (create-index-cmd (car idx) (cadr idx) (caddr idx)) conn))) (defun make-usrl (conn) (if (eql :mysql *umls-sql-type*) (sql-execute "drop table if exists USRL" conn) (ignore-errors (sql-execute "drop table USRL" conn))) (sql-execute "create table USRL (sab varchar(80), srl integer)" conn) (dolist (tuple (mutex-sql-query "select distinct SAB,SRL from MRCONSO order by SAB asc")) (sql-execute (format nil "insert into USRL (sab,srl) values ('~a',~d)" (car tuple) (ensure-integer (cadr tuple))) conn))) (defun sql-create-special-tables (conn) (make-usrl conn) (make-ustats)) (defun create-umls-db-by-insert (&key verbose) "SQL Databases: initializes entire database via SQL insert commands" (ensure-ucols+ufiles) (ensure-preparse) (with-sql-connection (conn) (sql-drop-tables conn) (sql-create-tables conn) (sql-insert-all-values conn) (sql-create-indexes conn) (sql-create-custom-tables conn) (sql-create-indexes conn :indexes +custom-index-cols+ :verbose verbose) (sql-create-special-tables conn))) (defun create-umls-db (&key (extension "-trans") (force-translation nil) (verbose nil)) "SQL Databases: initializes entire database via SQL copy commands. This is much faster that using create-umls-db-insert." (when verbose (format t "UMLS Import: Starting.~%")) (ensure-ucols+ufiles) (when verbose (format t "UMLS Import: Preparsing files.~%")) (ensure-preparse) (when verbose (format t "UMLS Import: Converting text UMLS files to optimized format.~%")) (translate-all-files :extension extension :verbose verbose :force force-translation) (let ((copy-cmd (ecase (umls-sql-type) (:mysql #'mysql-copy-cmd) (:postgresql #'pg-copy-cmd)))) (with-sql-connection (conn) (clsql:truncate-database :database conn) (sql-drop-tables conn) (sql-create-tables conn) (dolist (file *umls-files*) (when verbose (format t "UMLS Import: Importing file ~A to SQL.~%" (fil file))) (sql-execute (funcall copy-cmd file extension) conn)) (When verbose (format t "UMLS Import: Creating SQL indices.~%")) (sql-create-indexes conn :verbose verbose) (When verbose (format t "UMLS Import: Creating custom tables.~%")) (sql-create-custom-tables conn) (When verbose (format t "UMLS Import: Creating custom indices.~%")) (sql-create-indexes conn :indexes +custom-index-cols+ :verbose verbose) (When verbose (format t "UMLS Import: Creating special tables.~%")) (sql-create-special-tables conn))) (When verbose (format t "UMLS Import: Completed.~%")) t) (defun translate-all-files (&key (extension "-trans") verbose force) "Translate all *umls-files* to optimized import format." (when verbose (format t "UMLS Import: Translating file ~A.~%" (fil (find-ufile "MRXW_NONENG.RRF")))) (make-noneng-index-file extension :force force) (dolist (f (remove "MRXW_NONENG.RRF" *umls-files* :test #'string= :key #'fil)) (when verbose (format t "UMLS Import: Translating file ~A.~%" (fil f))) (translate-umls-file f extension :force force))) (defun translate-umls-file (file extension &key force) "Translate a umls file into a format suitable for sql copy cmd" (translate-files file extension (list file) :force force)) (defun make-noneng-index-file (extension &key force) "Make non-english index file" (translate-files (find-ufile "MRXW_NONENG.RRF") extension (noneng-lang-index-files) :force force)) (defun verify-translation-file (output-path input-ufiles) "Returns t if translation file exists and is correct size. Warns and deletes incomplete translation file." (when (probe-file output-path) (let ((translated-lines 0) (input-lines 0) (eof (cons nil nil))) (catch 'done-counting (with-open-file (ts output-path :direction :input #+(and clisp unicode) :external-format #+(and clisp unicode) charset:utf-8) (do () ((eq (read-line ts nil eof) eof)) (incf translated-lines))) (dolist (input-ufile input-ufiles) (with-umls-ufile (line input-ufile) (incf input-lines) (when (> input-lines translated-lines) (throw 'done-counting 'incomplete))))) (cond ((< input-lines translated-lines) (format t "Translated file ~A incomplete, deleting...~%" output-path) (delete-file output-path) nil) ((eql input-lines translated-lines) (format t "Translated file ~A already exists: skipping...~%" output-path) t) ((eql input-lines 0) (warn "The number of input lines is 0 for output file ~A." output-path) nil) ((> translated-lines input-lines) (error "Shouldn't happen. Translated lines of ~A is ~D, greater than input lines ~D" output-path translated-lines input-lines) (delete-file output-path) nil))))) (defun translate-files (out-ufile extension input-ufiles &key force) "Translate a umls file into a format suitable for sql copy cmd" (let ((output-path (ufile-pathname out-ufile extension))) (when (and (not force) (verify-translation-file output-path input-ufiles)) (return-from translate-files output-path)) (with-open-file (ostream output-path :direction :output :if-exists :overwrite :if-does-not-exist :create #+(and clisp unicode) :external-format #+(and clisp unicode) charset:utf-8) (dolist (input-ufile input-ufiles) (with-umls-ufile (line input-ufile) (translate-line out-ufile line ostream) (princ #\newline ostream)))))) (defun translate-line (file line strm) "Translate a single line for sql output" (flet ((col-value (col value) (if (eq (datatype col) 'sql-u) (let ((ui (parse-ui value ""))) (if (stringp ui) ui (write-to-string ui))) (escape-backslashes value)))) (print-separated-strings strm "|" (mapcar #'col-value (remove-custom-cols (ucols file)) line) (custom-col-values (custom-ucols-for-file file) line nil)))) (defun pg-copy-cmd (file extension) "Return postgresql copy statement for a file" (format nil "COPY ~a FROM '~a' using delimiters '|' with null as ''" (table file) (ufile-pathname file extension))) (defun mysql-copy-cmd (file extension &key (local-file t)) "Return mysql copy statement for a file" (format nil "LOAD DATA ~AINFILE '~a' INTO TABLE ~a FIELDS TERMINATED BY '|'" (if local-file "LOCAL " "") (namestring (ufile-pathname file extension)) (table file))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Routines for analyzing cost of fixed size storage ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun umls-fixed-size-waste () "Display storage waste if using all fixed size storage" (let ((totalwaste 0) (totalunavoidable 0) (totalavoidable 0) (unavoidable '()) (avoidable '())) (dolist (file *umls-files*) (dolist (col (ucols file)) (let* ((avwaste (- (cmax col) (av col))) (cwaste (* avwaste (rws file)))) (when (plusp cwaste) (if (<= avwaste 6) (progn (incf totalunavoidable cwaste) (push (list (fil file) (col col) avwaste cwaste) unavoidable)) (progn (incf totalavoidable cwaste) (push (list (fil file) (col col) avwaste cwaste) avoidable))) (incf totalwaste cwaste))))) (values totalwaste totalavoidable totalunavoidable (nreverse avoidable) (nreverse unavoidable)))) (defun display-waste () (ensure-ucols+ufiles) (multiple-value-bind (tw ta tu al ul) (umls-fixed-size-waste) (format t "Total waste: ~d~%" tw) (format t "Total avoidable: ~d~%" ta) (format t "Total unavoidable: ~d~%" tu) (format t "Avoidable:~%") (dolist (w al) (format t " (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w))) (format t "Unavoidable:~%") (dolist (w ul) (format t " (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w))) )) (defun max-umls-field () "Return length of longest field" (declare (optimize (speed 3) (space 0))) (ensure-ucols+ufiles) (let ((max 0)) (declare (type (integer 0 1000000) max)) (dolist (ucol *umls-cols*) (when (> (the (integer 0 1000000) (cmax ucol)) max) (setq max (cmax ucol)))) max)) (defun max-umls-row () "Return length of longest row" (declare (optimize (speed 3) (space 0))) (ensure-ucols+ufiles) (let ((rowsizes '())) (dolist (file *umls-files*) (let ((row 0)) (declare (type (integer 0 1000000) row)) (dolist (ucol (ucols file)) (let* ((col-max (cmax ucol)) (max-with-delim (1+ col-max))) (declare (type (integer 0 1000000) col-max max-with-delim)) (incf row max-with-delim))) (push row rowsizes))) (car (sort rowsizes #'>))))